commit a9560a2b51191bbd832641fb8b0f9d88e89b5d36 (HEAD, refs/remotes/origin/master) Author: Dario Gjorgjevski Date: Mon Apr 26 09:57:23 2021 +0200 Fix typo in tramp-get-remote-gid * lisp/net/tramp.el (tramp-get-remote-gid): Pass the correct operation to find-file-name-handler. (Bug#48026) diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el index a411aafa87..dc34b8f024 100644 --- a/lisp/net/tramp.el +++ b/lisp/net/tramp.el @@ -5080,7 +5080,7 @@ ID-FORMAT valid values are `string' and `integer'." (or (when-let ((handler (find-file-name-handler - (tramp-make-tramp-file-name vec) 'tramp-get-remote-uid))) + (tramp-make-tramp-file-name vec) 'tramp-get-remote-gid))) (funcall handler #'tramp-get-remote-gid vec id-format)) ;; Ensure there is a valid result. (and (equal id-format 'integer) tramp-unknown-id-integer) commit 50f29f6a282b7426377be5fb54322fc5b5a487fc Author: Stefan Kangas Date: Mon Apr 26 04:39:51 2021 +0200 * src/editfns.c (Fpropertize): Doc fix; reference Info manual. diff --git a/src/editfns.c b/src/editfns.c index bc73c1e2c5..04b8e85d9c 100644 --- a/src/editfns.c +++ b/src/editfns.c @@ -2941,6 +2941,8 @@ DEFUN ("propertize", Fpropertize, Spropertize, 1, MANY, 0, First argument is the string to copy. Remaining arguments form a sequence of PROPERTY VALUE pairs for text properties to add to the result. + +See Info node `(elisp) Text Properties' for more information. usage: (propertize STRING &rest PROPERTIES) */) (ptrdiff_t nargs, Lisp_Object *args) { commit 890631bc6ab2825e079db77eeb66297902d5460f Author: Glenn Morris Date: Sun Apr 25 17:49:42 2021 -0700 ; NEWS copyedits diff --git a/etc/NEWS b/etc/NEWS index 7e30941e4b..9bf232ac02 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -25,14 +25,13 @@ applies, and please also update docstrings as needed. * Installation Changes in Emacs 28.1 ** Emacs now optionally supports native compilation of Lisp files. -To enable, configure Emacs with the '--with-native-compilation' option -to the 'configure' script. This requires to have the libgccjit -library to be installed and functional. +To enable this, configure Emacs with the '--with-native-compilation' option. +This requires the libgccjit library to be installed and functional. --- ** Support for building with Motif has been removed. -** Cairo graphics library is now used by default if found. +** The Cairo graphics library is now used by default if present. '--with-cairo' is now the default, if the appropriate development files are found by 'configure'. Note that building with Cairo means using Pango instead of libXFT for font support. Since Pango 1.44 has commit b7c22fab7d0c9644276127701191d5297e9023b4 Author: Glenn Morris Date: Sun Apr 25 17:24:48 2021 -0700 ; Add 2021 to copyright years diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el index 5b189e70be..d22d19ce1e 100644 --- a/lisp/emacs-lisp/comp-cstr.el +++ b/lisp/emacs-lisp/comp-cstr.el @@ -1,9 +1,8 @@ ;;; comp-cstr.el --- native compiler constraint library -*- lexical-binding: t -*- -;; Author: Andrea Corallo - ;; Copyright (C) 2020-2021 Free Software Foundation, Inc. +;; Author: Andrea Corallo ;; Keywords: lisp ;; Package: emacs diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 82799a4d4e..fd8a8c61cc 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1,9 +1,8 @@ ;;; comp.el --- compilation of Lisp code into native code -*- lexical-binding: t -*- -;; Author: Andrea Corallo - ;; Copyright (C) 2019-2021 Free Software Foundation, Inc. +;; Author: Andrea Corallo ;; Keywords: lisp ;; Package: emacs diff --git a/src/comp.h b/src/comp.h index 03d22dfaa0..c4af4193d0 100644 --- a/src/comp.h +++ b/src/comp.h @@ -1,5 +1,6 @@ /* Elisp native compiler definitions -Copyright (C) 2019-2020 Free Software Foundation, Inc. + +Copyright (C) 2019-2021 Free Software Foundation, Inc. This file is part of GNU Emacs. diff --git a/test/lisp/emacs-lisp/comp-cstr-tests.el b/test/lisp/emacs-lisp/comp-cstr-tests.el index c2492b93f6..2e4628522f 100644 --- a/test/lisp/emacs-lisp/comp-cstr-tests.el +++ b/test/lisp/emacs-lisp/comp-cstr-tests.el @@ -1,6 +1,6 @@ ;;; comp-cstr-tests.el --- unit tests for src/comp.c -*- lexical-binding: t; -*- -;; Copyright (C) 2020 Free Software Foundation, Inc. +;; Copyright (C) 2020-2021 Free Software Foundation, Inc. ;; Author: Andrea Corallo diff --git a/test/src/comp-test-funcs-dyn.el b/test/src/comp-test-funcs-dyn.el index 67db7587bf..3118455e3f 100644 --- a/test/src/comp-test-funcs-dyn.el +++ b/test/src/comp-test-funcs-dyn.el @@ -1,6 +1,6 @@ ;;; comp-test-funcs-dyn.el --- compilation unit tested by comp-tests.el -*- lexical-binding: nil; -*- -;; Copyright (C) 2020 Free Software Foundation, Inc. +;; Copyright (C) 2020-2021 Free Software Foundation, Inc. ;; Author: Andrea Corallo diff --git a/test/src/comp-test-pure.el b/test/src/comp-test-pure.el index f606a44a10..5c1d2d1747 100644 --- a/test/src/comp-test-pure.el +++ b/test/src/comp-test-pure.el @@ -1,6 +1,6 @@ ;;; comp-test-pure.el --- compilation unit tested by comp-tests.el -*- lexical-binding: t; -*- -;; Copyright (C) 2020 Free Software Foundation, Inc. +;; Copyright (C) 2020-2021 Free Software Foundation, Inc. ;; Author: Andrea Corallo diff --git a/test/src/emacs-tests.el b/test/src/emacs-tests.el index 87c3e84cdd..ee5586fbaf 100644 --- a/test/src/emacs-tests.el +++ b/test/src/emacs-tests.el @@ -1,6 +1,6 @@ ;;; emacs-tests.el --- unit tests for emacs.c -*- lexical-binding: t; -*- -;; Copyright (C) 2020 Free Software Foundation, Inc. +;; Copyright (C) 2020-2021 Free Software Foundation, Inc. ;; This file is part of GNU Emacs. commit 8e2faa74ce188da536a81cbece3b13f8f16f2bd6 Author: Stefan Monnier Date: Sun Apr 25 17:29:01 2021 -0400 * lisp/url/url-proxy.el (url-find-proxy-for-url): Minor simplification diff --git a/lisp/url/url-proxy.el b/lisp/url/url-proxy.el index 1b3b1905e3..c89c1b6bc3 100644 --- a/lisp/url/url-proxy.el +++ b/lisp/url/url-proxy.el @@ -49,9 +49,7 @@ ;; Not sure how I should handle gracefully degrading from one proxy to ;; another, so for now just deal with the first one ;; (while proxies - (if (listp proxies) - (setq proxy (car proxies)) - (setq proxy proxies)) + (setq proxy (if (listp proxies) (car proxies) proxies)) (cond ((string-match "^DIRECT" proxy) nil) ((string-match "^PROXY +" proxy) commit 83a915d3dfafd5f3d737afe1e13b75e4dd3aef96 Author: Andrea Corallo Date: Sun Apr 25 20:56:32 2021 +0200 * lisp/startup.el (comp-eln-load-path): Silence a warning. diff --git a/lisp/startup.el b/lisp/startup.el index 89d4c8ae31..a21372a046 100644 --- a/lisp/startup.el +++ b/lisp/startup.el @@ -519,6 +519,7 @@ DIRS are relative." xdg-dir) (t emacs-d-dir)))) +(defvar comp-eln-load-path) (defun normal-top-level () "Emacs calls this function when it first starts up. It sets `command-line-processed', processes the command-line, @@ -538,7 +539,6 @@ It is the default value of the variable `top-level'." (when (featurep 'nativecomp) ;; Form `comp-eln-load-path'. - (defvar comp-eln-load-path) (let ((path-env (getenv "EMACSNATIVELOADPATH"))) (when path-env (dolist (path (split-string path-env path-separator)) commit 6bfe589078d346df6b19fa2b6662aa9934a9ac44 Author: Lars Ingebrigtsen Date: Sun Apr 25 20:54:26 2021 +0200 Hack around problems in Turkish environments in url-proxy * lisp/url/url-proxy.el (url-find-proxy-for-url): Work around a problem in Turkish language environments (where a downcased I is ?ı (bug#44604). diff --git a/lisp/url/url-proxy.el b/lisp/url/url-proxy.el index 8436c7a4be..1b3b1905e3 100644 --- a/lisp/url/url-proxy.el +++ b/lisp/url/url-proxy.el @@ -53,10 +53,10 @@ (setq proxy (car proxies)) (setq proxy proxies)) (cond - ((string-match "^direct" proxy) nil) - ((string-match "^proxy +" proxy) + ((string-match "^DIRECT" proxy) nil) + ((string-match "^PROXY +" proxy) (concat "http://" (substring proxy (match-end 0)) "/")) - ((string-match "^socks +" proxy) + ((string-match "^SOCKS +" proxy) (concat "socks://" (substring proxy (match-end 0)))) (t (display-warning 'url (format "Unknown proxy directive: %s" proxy) :error) commit ec2ccae3e6844f0f5dfa27c386129bbdb576b2ea Author: Stefan Kangas Date: Sun Apr 25 20:47:20 2021 +0200 * lisp/emacs-lisp/comp.el (no-native-compile): Minor doc fixes. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index ab5a06e7e8..82799a4d4e 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -193,7 +193,7 @@ Note that when `no-byte-compile' is set to non-nil it overrides the value of `no-native-compile'. This is normally set in local file variables at the end of the elisp file: -\;; Local Variables:\n;; no-native-compile: t\n;; End: ") +\;; Local Variables:\n;; no-native-compile: t\n;; End:") ;;;###autoload(put 'no-native-compile 'safe-local-variable 'booleanp) (defvar comp-log-time-report nil @@ -561,7 +561,7 @@ Useful to hook into pass checkers.") for cstr = (comp-type-spec-to-cstr type-spec) do (puthash f cstr h) finally return h) - "Hash table function -> `comp-constraint'") + "Hash table function -> `comp-constraint'.") (defconst comp-known-predicates '((arrayp . array) @@ -598,7 +598,7 @@ Useful to hook into pass checkers.") for cstr = (comp-type-spec-to-cstr type-spec) do (puthash pred cstr h) finally return h) - "Hash table function -> `comp-constraint'") + "Hash table function -> `comp-constraint'.") (defun comp-known-predicate-p (predicate) "Return t if PREDICATE is known." @@ -692,7 +692,7 @@ Useful to hook into pass checkers.") (- (comp-vec-end vec) (comp-vec-beg vec))) (defsubst comp-vec--verify-idx (vec idx) - "Check whether idx is in bounds for VEC." + "Check whether IDX is in bounds for VEC." (cl-assert (and (< idx (comp-vec-end vec)) (>= idx (comp-vec-beg vec))))) @@ -949,7 +949,7 @@ To be used by all entry points." (when (memq function '(eq eql equal)) t)) (defun comp-arithm-cmp-fun-p (function) - "Predicate for arithmetic comparision functions." + "Predicate for arithmetic comparison functions." (when (memq function '(= > < >= <=)) t)) (defun comp-set-op-p (op) @@ -3269,7 +3269,6 @@ FUNCTION can be a function-name or byte compiled function." (gethash func (comp-ctxt-byte-func-to-func-h comp-ctxt)))) (defun comp-call-optim-form-call (callee args) - "" (cl-flet ((fill-args (args total) ;; Fill missing args to reach TOTAL (append args (cl-loop repeat (- total (length args)) @@ -3482,7 +3481,7 @@ These are substituted with a normal 'set' op." ;;; Final pass specific code. (defun comp-args-to-lambda-list (args) - "Return a lambda list for args." + "Return a lambda list for ARGS." (cl-loop with res repeat (comp-args-base-min args) commit 230f90d6e278ac4012ea7fe7fcf5e859c659f717 Author: Stefan Kangas Date: Sun Apr 25 17:33:41 2021 +0200 * lisp/help-macro.el: Remove stale Change Log. diff --git a/lisp/help-macro.el b/lisp/help-macro.el index 6a0e11574c..7fe1fb6c3d 100644 --- a/lisp/help-macro.el +++ b/lisp/help-macro.el @@ -59,12 +59,6 @@ ;;-> (define-key c-mp "\C-h" 'help-for-empire-redistribute-map) ;;-> (define-key c-mp help-character 'help-for-empire-redistribute-map) -;;; Change Log: -;; -;; 22-Jan-1991 Lynn Slater x2048 -;; Last Modified: Mon Oct 1 11:43:52 1990 #3 (Lynn Slater) -;; documented better - ;;; Code: (require 'backquote) commit 2a33fc8d19973d6fa8ccd37a4203fae99c214893 Author: Lars Ingebrigtsen Date: Sun Apr 25 20:36:01 2021 +0200 Adjust regexp to extra native-comp lines diff --git a/admin/emake b/admin/emake index e95b17dbdc..c909bd7633 100755 --- a/admin/emake +++ b/admin/emake @@ -68,6 +68,8 @@ GEN.*loaddefs|\ ^\"configure\" file built.|\ ^There seems to be no|\ ^config.status:|\ +ELN_DESTDIR|\ +^ *--bin-dest |\ ^ *$|\ ^Makefile built|\ The GNU allocators don't work|\ commit 289000eee729689b0cf362a21baa40ac7f9506f6 Merge: 8f63f0078a fa65c044f2 Author: Andrea Corallo Date: Sun Apr 25 20:06:22 2021 +0200 Merge branch 'feature/native-comp' into into trunk commit 8f63f0078a23421eada97b4da51b9308b82532ce Author: Lars Ingebrigtsen Date: Sun Apr 25 19:47:06 2021 +0200 Revert window/winner changes (Revert 0454bfd3313) See bug#23621 for an explanation. diff --git a/lisp/window.el b/lisp/window.el index 06d3e43f36..036eb271ee 100644 --- a/lisp/window.el +++ b/lisp/window.el @@ -3755,8 +3755,6 @@ WINDOW must be a valid window and defaults to the selected one. If the option `window-resize-pixelwise' is non-nil minimize WINDOW pixelwise." (interactive) - (when switch-to-buffer-preserve-window-point - (window--before-delete-windows window)) (setq window (window-normalize-window window)) (window-resize window @@ -4142,41 +4140,6 @@ frame can be safely deleted." (throw 'done t) (setq parent (window-parent parent)))))))) -;; This function is called by `delete-window' and -;; `delete-other-windows' when `switch-to-buffer-preserve-window-point' -;; evaluates non-nil: it allows `winner-undo' to restore the -;; buffer point from deleted windows (Bug#23621). -(defun window--before-delete-windows (&optional window) - "Update `window-prev-buffers' before delete a window. -Optional arg WINDOW, if non-nil, update WINDOW-START and POS -in `window-prev-buffers' for all windows displaying same -buffer as WINDOW. Otherwise, update `window-prev-buffers' for -all windows. - -The new values for WINDOW-START and POS are those -returned by `window-start' and `window-point' respectively. - -This function is called only if `switch-to-buffer-preserve-window-point' -evaluates non-nil." - (dolist (win (window-list nil 'no-minibuf)) - (let* ((buf (window-buffer (or window win))) - (start (window-start win)) - (pos (window-point win)) - (entry (assq buf (window-prev-buffers win)))) - (cond (entry - (let ((marker (nth 2 entry))) - (unless (= pos marker) - (set-marker (nth 1 entry) start buf) - (set-marker marker pos buf)))) - (t - (let ((prev-buf (window-prev-buffers win)) - (start-m (make-marker)) - (pos-m (make-marker))) - (set-marker start-m start buf) - (set-marker pos-m pos buf) - (push (list buf start-m pos-m) prev-buf) - (set-window-prev-buffers win prev-buf))))))) - (defun delete-window (&optional window) "Delete WINDOW. WINDOW must be a valid window and defaults to the selected one. @@ -4195,8 +4158,6 @@ argument. Signal an error if WINDOW is either the only window on its frame, the last non-side window, or part of an atomic window that is its frame's root window." (interactive) - (when switch-to-buffer-preserve-window-point - (window--before-delete-windows)) (setq window (window-normalize-window window)) (let* ((frame (window-frame window)) (function (window-parameter window 'delete-window)) diff --git a/lisp/winner.el b/lisp/winner.el index f30fa6cf5c..8062fbae90 100644 --- a/lisp/winner.el +++ b/lisp/winner.el @@ -283,17 +283,8 @@ You may want to include buffer names such as *Help*, *Apropos*, ;; Restore points (dolist (win (winner-sorted-window-list)) (unless (and (pop alive) - (let* ((buf (window-buffer win)) - (pos (winner-get-point (window-buffer win) win)) - (entry (assq buf (window-prev-buffers win)))) - ;; Try to restore point of buffer in the selected - ;; window (Bug#23621). - (let ((marker (nth 2 entry))) - (when (and switch-to-buffer-preserve-window-point - marker - (not (= marker pos))) - (setq pos marker)) - (setf (window-point win) pos))) + (setf (window-point win) + (winner-get-point (window-buffer win) win)) (not (or (member (buffer-name (window-buffer win)) winner-boring-buffers) (and winner-boring-buffers-regexp commit 142babb9bd8585136d4d56fb8b6dc2761d891c79 Author: Alan Mackenzie Date: Sun Apr 25 17:40:16 2021 +0000 CC Mode: Get proper search limits in c-font-lock-cut-off-declarators * lisp/progmodes/cc-fonts.el (c-font-lock-cut-off-declarators): Instead of using a crude 2,000 characters back limit for backward searching, which is erroneous when that point is in a literal, use the already calculated c-determine-limit result. diff --git a/lisp/progmodes/cc-fonts.el b/lisp/progmodes/cc-fonts.el index fdef0840cd..a7c87125cd 100644 --- a/lisp/progmodes/cc-fonts.el +++ b/lisp/progmodes/cc-fonts.el @@ -1669,9 +1669,7 @@ casts and declarations are fontified. Used on level 2 and higher." c-recognize-knr-p) ; Strictly speaking, bogus, but it ; speeds up lisp.h tremendously. (save-excursion - (when (not (c-back-over-member-initializers - (max (- (point) 2000) (point-min)))) ; c-determine-limit - ; is too slow, here. + (when (not (c-back-over-member-initializers decl-search-lim)) (unless (or (eobp) (looking-at "\\s(\\|\\s)")) (forward-char)) commit 6dabbddb5fc2a605bd23b3460d791b8e63bcf8f7 Merge: 6f9180ecb6 7d5b973959 Author: Glenn Morris Date: Sun Apr 25 09:16:09 2021 -0700 Merge from origin/emacs-27 7d5b973959 (origin/emacs-27) * doc/misc/cl.texi (For Clauses): Minor ... 4570781f8d ; * doc/lispref/files.texi (Directory Names): Add missing ... 1b52fd538d Minor update for make-tarball.txt 8efb8491b2 * doc/misc/cl.texi (Iteration Clauses): fix `never' clause... 0873134682 ; Fix Texinfo in last change to minibuf.texi. cad8913c89 Improve filling-related documentation 2b7eed23eb ; * doc/lispref/keymaps.texi (Easy Menu): Fix typo. 47fc92cefc Fix reference to "yanking" in the main Emacs manual 1789dcdb35 Improve documentation of 'map-y-or-n-p' commit 6f9180ecb6cc681fdc55ec7cea80c5d9140e152c Author: Stefan Kangas Date: Sun Apr 25 16:57:47 2021 +0200 Add more scroll key bindings to make-help-screen * lisp/help-macro.el (make-help-screen): Add bindings to scroll on , , , . diff --git a/lisp/help-macro.el b/lisp/help-macro.el index 7fc128c73a..6a0e11574c 100644 --- a/lisp/help-macro.el +++ b/lisp/help-macro.el @@ -148,18 +148,23 @@ and then returns." (setq new-minor-mode-map-alist minor-mode-map-alist)) (goto-char (point-min)) (while (or (memq char (append help-event-list - (cons help-char '(?? ?\C-v ?\s ?\177 deletechar backspace vertical-scroll-bar ?\M-v)))) + (cons help-char '( ?? ?\C-v ?\s ?\177 deletechar backspace vertical-scroll-bar ?\M-v + next prior up down)))) (eq (car-safe char) 'switch-frame) (equal key "\M-v")) (condition-case nil (cond ((eq (car-safe char) 'switch-frame) (handle-switch-frame char)) - ((memq char '(?\C-v ?\s)) + ((memq char '(?\C-v ?\s next)) (scroll-up)) - ((or (memq char '(?\177 ?\M-v deletechar backspace)) + ((or (memq char '(?\177 ?\M-v deletechar backspace prior)) (equal key "\M-v")) - (scroll-down))) + (scroll-down)) + ((memq char '(down)) + (scroll-up 1)) + ((memq char '(up)) + (scroll-down 1))) (error nil)) (let ((cursor-in-echo-area t) (overriding-local-map local-map)) commit a6d40a289e2e177b2b508a3380021f66b16a1d19 Author: Gregory Heytings Date: Sun Apr 25 13:30:15 2021 +0000 Fix the handling of the Delete key in help screens. * lisp/help-macro.el (make-help-screen): Handle the Delete key in help screens as in Emacs 23 and earlier. Copyright-paperwork-exempt: yes diff --git a/lisp/help-macro.el b/lisp/help-macro.el index 96edeaf466..7fc128c73a 100644 --- a/lisp/help-macro.el +++ b/lisp/help-macro.el @@ -148,7 +148,7 @@ and then returns." (setq new-minor-mode-map-alist minor-mode-map-alist)) (goto-char (point-min)) (while (or (memq char (append help-event-list - (cons help-char '(?? ?\C-v ?\s ?\177 delete backspace vertical-scroll-bar ?\M-v)))) + (cons help-char '(?? ?\C-v ?\s ?\177 deletechar backspace vertical-scroll-bar ?\M-v)))) (eq (car-safe char) 'switch-frame) (equal key "\M-v")) (condition-case nil @@ -157,7 +157,7 @@ and then returns." (handle-switch-frame char)) ((memq char '(?\C-v ?\s)) (scroll-up)) - ((or (memq char '(?\177 ?\M-v delete backspace)) + ((or (memq char '(?\177 ?\M-v deletechar backspace)) (equal key "\M-v")) (scroll-down))) (error nil)) commit 13a248f7e7e57b7df736a7c101d8e1690ae755ac Author: Stefan Kangas Date: Sun Apr 25 13:57:32 2021 +0200 ; * lisp/help.el (help-for-help): Fix thinko. diff --git a/lisp/help.el b/lisp/help.el index 8234bbd34b..e143501081 100644 --- a/lisp/help.el +++ b/lisp/help.el @@ -239,7 +239,7 @@ Do not call this in the scope of `with-help-window'." (help--key-description-fontified "\C-s") " to search, or \\\\[help-quit] to exit.)" (help--for-help-make-sections - '(("Commands, Keys and Functions" + `(("Commands, Keys and Functions" ("describe-mode" "Show help for current major and minor modes and their commands") ("describe-bindings" "Show all key bindings") @@ -273,8 +273,8 @@ Do not call this in the scope of `with-help-window'." ("help-with-tutorial" "Start the Emacs tutorial") ("view-echo-area-messages" "Show recent messages (from echo area)") - ("view-lossage" (format "Show last %d input keystrokes (lossage)" - (lossage-size))) + ("view-lossage" ,(format "Show last %d input keystrokes (lossage)" + (lossage-size))) ("display-local-help" "Show local help at point")) ("Miscellaneous" ("about-emacs" "About Emacs") commit bbe8cb884963bdab64a8b80204703ba46935e0ac Author: Stefan Kangas Date: Sun Apr 25 13:12:48 2021 +0200 * lisp/ses.el: Doc fixes. diff --git a/lisp/ses.el b/lisp/ses.el index 98785b6b93..bc3c2deaa1 100644 --- a/lisp/ses.el +++ b/lisp/ses.el @@ -172,14 +172,14 @@ Each function is called with ARG=1." (defvar ses--completion-table nil "Set globally to what completion table to use depending on type - of completion (local printers, cells, etc.). We need to go - through a local variable to pass the SES buffer local variable - to completing function while the current buffer is the - minibuffer.") +of completion (local printers, cells, etc.). We need to go +through a local variable to pass the SES buffer local variable +to completing function while the current buffer is the +minibuffer.") (defvar ses--list-orig-buffer nil - "Calling buffer for SES listing help. Used for listing local - printers or renamed cells.") + "Calling buffer for SES listing help. +Used for listing local printers or renamed cells.") (defconst ses-mode-edit-map @@ -395,8 +395,9 @@ left-justification of the result. Set to error-signal if `ses-call-printer' encountered an error during printing. Otherwise nil.") (defvar ses-start-time nil - "Time when current operation started. Used by `ses--time-check' to decide -when to emit a progress message.") + "Time when current operation started. +Used by `ses--time-check' to decide when to emit a progress +message.") ;;---------------------------------------------------------------------------- @@ -560,9 +561,10 @@ the corresponding cell with name PROPERTY-NAME." (eq (ses-cell-symbol (car rowcol) (cdr rowcol)) sym)))))) (defun ses--cell (sym value formula printer references) - "Load a cell SYM from the spreadsheet file. Does not recompute VALUE from -FORMULA, does not reprint using PRINTER, does not check REFERENCES. -Safety-checking for FORMULA and PRINTER are deferred until first use." + "Load a cell SYM from the spreadsheet file. +Does not recompute VALUE from FORMULA, does not reprint using +PRINTER, does not check REFERENCES. Safety-checking for FORMULA +and PRINTER are deferred until first use." (let ((rowcol (ses-sym-rowcol sym))) (ses-formula-record formula) (ses-printer-record printer) @@ -580,8 +582,7 @@ Safety-checking for FORMULA and PRINTER are deferred until first use." (set sym value)) (defun ses-local-printer-compile (printer) - "Convert local printer function into faster printer -definition." + "Convert local printer function into faster printer definition." (cond ((functionp printer) printer) ((stringp printer) @@ -610,8 +611,8 @@ Return the printer info." ses--local-printer-hashmap)) (defmacro ses-column-widths (widths) - "Load the vector of column widths from the spreadsheet file. This is a -macro to prevent propagate-on-load viruses." + "Load the vector of column widths from the spreadsheet file. +This is a macro to prevent propagate-on-load viruses." (or (and (vectorp widths) (= (length widths) ses--numcols)) (error "Bad column-width vector")) ;;To save time later, we also calculate the total width of each line in the @@ -748,8 +749,8 @@ for this spreadsheet." (intern (concat (ses-column-letter col) (number-to-string (1+ row))))) (defun ses-decode-cell-symbol (str) - "Decode a symbol \"A1\" => (0,0). Return nil if STR is not a -canonical cell name." + "Decode a symbol \"A1\" => (0,0). +Return nil if STR is not a canonical cell name." (let (case-fold-search) (and (string-match "\\`\\([A-Z]+\\)\\([0-9]+\\)\\'" str) (let* ((col-str (match-string-no-properties 1 str)) @@ -1061,15 +1062,15 @@ the old and FORCE is nil." (ses-cell-set-formula row col nil)) (defcustom ses-self-reference-early-detection nil - "True if cycle detection is early for cells that refer to themselves." + "Non-nil if cycle detection is early for cells that refer to themselves." :version "24.1" :type 'boolean :group 'ses) (defun ses-update-cells (list &optional force) - "Recalculate cells in LIST, checking for dependency loops. Prints -progress messages every second. Dependent cells are not recalculated -if the cell's value is unchanged and FORCE is nil." + "Recalculate cells in LIST, checking for dependency loops. +Print progress messages every second. Dependent cells are not +recalculated if the cell's value is unchanged and FORCE is nil." (let ((ses--deferred-recalc list) (nextlist list) (pos (point)) @@ -2025,7 +2026,7 @@ Delete overlays, remove special text properties." When you invoke SES in a new buffer, it is divided into cells that you can enter data into. You can navigate the cells with the arrow keys and add more cells with the tab key. The contents -of these cells can be numbers, text, or Lisp expressions. (To +of these cells can be numbers, text, or Lisp expressions. (To enter text, enclose it in double quotes.) In an expression, you can use cell coordinates to refer to the @@ -2131,9 +2132,9 @@ formula: (defun ses-command-hook () "Invoked from `post-command-hook'. If point has moved to a different cell, -moves the underlining overlay. Performs any recalculations or cell-data +move the underlining overlay. Perform any recalculations or cell-data writes that have been deferred. If buffer-narrowing has been deferred, -narrows the buffer now." +narrow the buffer now." (condition-case err (when (eq major-mode 'ses-mode) ; Otherwise, not our buffer anymore. (when ses--deferred-recalc @@ -2267,8 +2268,8 @@ Based on the current set of columns and `window-hscroll' position." (ses-jump cell))) (defun ses-reprint-all (&optional nonarrow) - "Recreate the display area. Calls all printer functions. Narrows to -print area if NONARROW is nil." + "Recreate the display area. Call all printer functions. +Narrow to print area if optional argument NONARROW is nil." (interactive "*P") (widen) (unless nonarrow @@ -2495,8 +2496,8 @@ to are recalculated first." (and collection (list start end collection)))))) (defun ses-edit-cell (row col newval) - "Display current cell contents in minibuffer, for editing. Returns nil if -cell formula was unsafe and user declined confirmation." + "Display current cell contents in minibuffer, for editing. +Return nil if cell formula was unsafe and user declined confirmation." (interactive (progn (barf-if-buffer-read-only) @@ -2559,8 +2560,9 @@ cell formula was unsafe and user declined confirmation." (funcall x 1)))) (defun ses-read-symbol (row col symb) - "Self-insert for a symbol as a cell formula. The set of all symbols that -have been used as formulas in this spreadsheet is available for completions." + "Self-insert for a symbol as a cell formula. +The set of all symbols that have been used as formulas in this +spreadsheet is available for completions." (interactive (let ((rowcol (progn (ses-check-curcell) (ses-sym-rowcol ses--curcell))) newval) @@ -2593,7 +2595,7 @@ With prefix, deletes several cells." (forward-char 1)))) (defun ses-clear-cell-backward (count) - "Move to previous cell and then delete it. With prefix, deletes several + "Move to previous cell and then delete it. With prefix, delete several cells." (interactive "*p") (if (< count 0) @@ -3371,9 +3373,9 @@ is non-nil. Newlines and tabs in the export text are escaped." ;;---------------------------------------------------------------------------- (defun ses-list-local-printers (&optional local-printer-hashmap) - "List local printers in a help buffer. Can be called either -during editing a printer or a formula, or while in the SES -buffer." + "List local printers in a help buffer. +Can be called either during editing a printer or a formula, or +while in the SES buffer." (interactive (list (cond ((derived-mode-p 'ses-mode) ses--local-printer-hashmap) @@ -3405,9 +3407,9 @@ buffer." (buffer-string))))))) (defun ses-list-named-cells (&optional named-cell-hashmap) - "List named cells in a help buffer. Can be called either -during editing a printer or a formula, or while in the SES -buffer." + "List named cells in a help buffer. +Can be called either during editing a printer or a formula, or +while in the SES buffer." (interactive (list (cond ((derived-mode-p 'ses-mode) ses--named-cell-hashmap) commit 34367cc8afb05cf32d5ed9659de92989b89898c8 Author: Stefan Kangas Date: Sun Apr 25 12:59:14 2021 +0200 Don't hard-code face of "Install" button * lisp/emacs-lisp/package.el (package-make-button): Use the 'custom-button' face for the "Install" button. (Bug#47944) diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index 64d7d56019..f2e83d3fda 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -2696,9 +2696,9 @@ PROPERTIES are passed to `insert-text-button', for which this function is a convenience wrapper used by `describe-package-1'." (let ((button-text (if (display-graphic-p) text (concat "[" text "]"))) (button-face (if (display-graphic-p) - '(:box (:line-width 2 :color "dark grey") - :background "light grey" - :foreground "black") + (progn + (require 'cus-edit) ; for the custom-button face + 'custom-button) 'link))) (apply #'insert-text-button button-text 'face button-face 'follow-link t properties))) commit 33ba69cd7698f9f25139a57c25172f3354f6579a Author: Stefan Kangas Date: Sun Apr 25 12:14:17 2021 +0200 Remove redundant #' before lambda in printing.el * lisp/printing.el (pr-menu-create, pr-eval-setting-alist) (pr-complete-alist, pr-file-list, pr-ps-file-list) (pr-insert-section-1, pr-insert-section-2) (pr-insert-section-4, pr-insert-section-5, pr-choice-alist) Remove redundant #' before lambda. diff --git a/lisp/printing.el b/lisp/printing.el index b9a2e33994..5c7da96551 100644 --- a/lisp/printing.el +++ b/lisp/printing.el @@ -4775,13 +4775,13 @@ If menu binding was not done, calls `pr-menu-bind'." (defun pr-menu-create (name alist var-sym fun entry index) (cons name (mapcar - #'(lambda (elt) - (let ((sym (car elt))) - (vector - (symbol-name sym) - `(,fun ',sym nil ',entry ',index) - :style 'radio - :selected `(eq ,var-sym ',sym)))) + (lambda (elt) + (let ((sym (car elt))) + (vector + (symbol-name sym) + `(,fun ',sym nil ',entry ',index) + :style 'radio + :selected `(eq ,var-sym ',sym)))) alist))) @@ -4883,23 +4883,23 @@ If menu binding was not done, calls `pr-menu-bind'." (cons inherits old))))) (mapc (cond ((not local) ; global settings - #'(lambda (option) - (let ((var-sym (car option))) - (or (eq var-sym 'inherits-from:) - (set var-sym (eval (cdr option))))))) + (lambda (option) + (let ((var-sym (car option))) + (or (eq var-sym 'inherits-from:) + (set var-sym (eval (cdr option))))))) (kill ; local settings with killing - #'(lambda (option) - (let ((var-sym (car option))) - (unless (eq var-sym 'inherits-from:) - (setq local-list (cons var-sym local-list)) - (set (make-local-variable var-sym) - (eval (cdr option))))))) + (lambda (option) + (let ((var-sym (car option))) + (unless (eq var-sym 'inherits-from:) + (setq local-list (cons var-sym local-list)) + (set (make-local-variable var-sym) + (eval (cdr option))))))) (t ; local settings without killing - #'(lambda (option) - (let ((var-sym (car option))) - (or (eq var-sym 'inherits-from:) - (set (make-local-variable var-sym) - (eval (cdr option)))))))) + (lambda (option) + (let ((var-sym (car option))) + (or (eq var-sym 'inherits-from:) + (set (make-local-variable var-sym) + (eval (cdr option)))))))) (nthcdr 3 setting)) local-list)))) @@ -5077,9 +5077,9 @@ If menu binding was not done, calls `pr-menu-bind'." (defun pr-complete-alist (prompt alist default) - (let ((collection (mapcar #'(lambda (elt) - (setq elt (car elt)) - (cons (symbol-name elt) elt)) + (let ((collection (mapcar (lambda (elt) + (setq elt (car elt)) + (cons (symbol-name elt) elt)) alist))) (cdr (assoc (completing-read (concat prompt ": ") collection nil t @@ -5413,19 +5413,19 @@ If menu binding was not done, calls `pr-menu-bind'." (defun pr-file-list (dir file-regexp fun) - (mapcar #'(lambda (file) - (and (or pr-list-directory - (not (file-directory-p file))) - (let ((buffer (pr-find-buffer-visiting file)) - pop-up-windows - pop-up-frames) - (and (or buffer - (file-readable-p file)) - (with-current-buffer (or buffer - (find-file-noselect file)) - (funcall fun) - (or buffer - (kill-buffer (current-buffer)))))))) + (mapcar (lambda (file) + (and (or pr-list-directory + (not (file-directory-p file))) + (let ((buffer (pr-find-buffer-visiting file)) + pop-up-windows + pop-up-frames) + (and (or buffer + (file-readable-p file)) + (with-current-buffer (or buffer + (find-file-noselect file)) + (funcall fun) + (or buffer + (kill-buffer (current-buffer)))))))) (directory-files dir t file-regexp))) @@ -5438,10 +5438,10 @@ If menu binding was not done, calls `pr-menu-bind'." (pr-delete-file-if-exists (setq filename (expand-file-name filename))) (let ((pr-spool-p t)) (pr-file-list dir file-regexp - #'(lambda () - (if (pr-auto-mode-p) - (pr-ps-mode n-up filename) - (pr-text2ps 'buffer n-up filename))))) + (lambda () + (if (pr-auto-mode-p) + (pr-ps-mode n-up filename) + (pr-text2ps 'buffer n-up filename))))) (or pr-spool-p (pr-despool-print filename))) @@ -5672,44 +5672,44 @@ COMMAND.exe, COMMAND.bat and COMMAND.com in this order." (pr-insert-checkbox "\n " 'pr-i-region - #'(lambda (widget &rest _ignore) - (let ((region-p (pr-interface-save - (ps-mark-active-p)))) - (cond ((null (widget-value widget)) ; widget is nil - (setq pr-i-region nil)) - (region-p ; widget is true and there is a region - (setq pr-i-region t) - (widget-value-set widget t) - (widget-setup)) ; MUST be called after widget-value-set - (t ; widget is true and there is no region - (ding) - (message "There is no region active") - (setq pr-i-region nil) - (widget-value-set widget nil) - (widget-setup))))) ; MUST be called after widget-value-set + (lambda (widget &rest _ignore) + (let ((region-p (pr-interface-save + (ps-mark-active-p)))) + (cond ((null (widget-value widget)) ; widget is nil + (setq pr-i-region nil)) + (region-p ; widget is true and there is a region + (setq pr-i-region t) + (widget-value-set widget t) + (widget-setup)) ; MUST be called after widget-value-set + (t ; widget is true and there is no region + (ding) + (message "There is no region active") + (setq pr-i-region nil) + (widget-value-set widget nil) + (widget-setup))))) ; MUST be called after widget-value-set " Region")) ;; 1a. Buffer: Mode (put 'pr-i-mode 'pr-widget (pr-insert-checkbox " " 'pr-i-mode - #'(lambda (widget &rest _ignore) - (let ((mode-p (pr-interface-save - (pr-mode-alist-p)))) - (cond - ((null (widget-value widget)) ; widget is nil - (setq pr-i-mode nil)) - (mode-p ; widget is true and there is a `mode' - (setq pr-i-mode t) - (widget-value-set widget t) - (widget-setup)) ; MUST be called after widget-value-set - (t ; widget is true and there is no `mode' - (ding) - (message - "This buffer isn't in a mode that printing treats specially.") - (setq pr-i-mode nil) - (widget-value-set widget nil) - (widget-setup))))) ; MUST be called after widget-value-set + (lambda (widget &rest _ignore) + (let ((mode-p (pr-interface-save + (pr-mode-alist-p)))) + (cond + ((null (widget-value widget)) ; widget is nil + (setq pr-i-mode nil)) + (mode-p ; widget is true and there is a `mode' + (setq pr-i-mode t) + (widget-value-set widget t) + (widget-setup)) ; MUST be called after widget-value-set + (t ; widget is true and there is no `mode' + (ding) + (message + "This buffer isn't in a mode that printing treats specially.") + (setq pr-i-mode nil) + (widget-value-set widget nil) + (widget-setup))))) ; MUST be called after widget-value-set " Mode\n")) ;; 1b. Directory: @@ -5769,14 +5769,14 @@ COMMAND.exe, COMMAND.bat and COMMAND.com in this order." (pr-insert-checkbox " " 'pr-i-despool - #'(lambda (widget &rest _ignore) - (if pr-spool-p - (setq pr-i-despool (not pr-i-despool)) - (ding) - (message "Can despool only when spooling is actually selected") - (setq pr-i-despool nil)) - (widget-value-set widget pr-i-despool) - (widget-setup)) ; MUST be called after widget-value-set + (lambda (widget &rest _ignore) + (if pr-spool-p + (setq pr-i-despool (not pr-i-despool)) + (ding) + (message "Can despool only when spooling is actually selected") + (setq pr-i-despool nil)) + (widget-value-set widget pr-i-despool) + (widget-setup)) ; MUST be called after widget-value-set " Despool ")) ;; 2. PostScript Printer: Preview Print Quit (pr-insert-button 'pr-interface-preview "Preview" " ") @@ -5835,9 +5835,9 @@ COMMAND.exe, COMMAND.bat and COMMAND.com in this order." ;; 4. Settings: ;; 4. Settings: Landscape Auto Region Verbose (pr-insert-checkbox "\n\n " 'ps-landscape-mode - #'(lambda (&rest _ignore) - (setq ps-landscape-mode (not ps-landscape-mode) - pr-file-landscape ps-landscape-mode)) + (lambda (&rest _ignore) + (setq ps-landscape-mode (not ps-landscape-mode) + pr-file-landscape ps-landscape-mode)) " Landscape ") (pr-insert-toggle 'pr-auto-region " Auto Region ") (pr-insert-toggle 'pr-buffer-verbose " Verbose\n ") @@ -5857,28 +5857,28 @@ COMMAND.exe, COMMAND.bat and COMMAND.com in this order." (pr-insert-toggle 'ps-zebra-stripes " Zebra Stripes") (pr-insert-checkbox " " 'pr-spool-p - #'(lambda (&rest _ignore) - (setq pr-spool-p (not pr-spool-p)) - (unless pr-spool-p - (setq pr-i-despool nil) - (pr-update-checkbox 'pr-i-despool))) + (lambda (&rest _ignore) + (setq pr-spool-p (not pr-spool-p)) + (unless pr-spool-p + (setq pr-i-despool nil) + (pr-update-checkbox 'pr-i-despool))) " Spool Buffer") ;; 4. Settings: Duplex Print with faces (pr-insert-checkbox "\n " 'ps-spool-duplex - #'(lambda (&rest _ignore) - (setq ps-spool-duplex (not ps-spool-duplex) - pr-file-duplex ps-spool-duplex)) + (lambda (&rest _ignore) + (setq ps-spool-duplex (not ps-spool-duplex) + pr-file-duplex ps-spool-duplex)) " Duplex ") (pr-insert-toggle 'pr-faces-p " Print with faces") ;; 4. Settings: Tumble Print via Ghostscript (pr-insert-checkbox "\n " 'ps-spool-tumble - #'(lambda (&rest _ignore) - (setq ps-spool-tumble (not ps-spool-tumble) - pr-file-tumble ps-spool-tumble)) + (lambda (&rest _ignore) + (setq ps-spool-tumble (not ps-spool-tumble) + pr-file-tumble ps-spool-tumble)) " Tumble ") (pr-insert-toggle 'pr-print-using-ghostscript " Print via Ghostscript\n ") @@ -5886,11 +5886,11 @@ COMMAND.exe, COMMAND.bat and COMMAND.com in this order." (pr-insert-toggle 'ps-print-upside-down " Upside-Down") (pr-insert-italic "\n\nSelect Pages : " 2 14) (pr-insert-menu "Page Parity" 'ps-even-or-odd-pages - (mapcar #'(lambda (alist) - (list 'choice-item - :format "%[%t%]" - :tag (cdr alist) - :value (car alist))) + (mapcar (lambda (alist) + (list 'choice-item + :format "%[%t%]" + :tag (cdr alist) + :value (car alist))) pr-even-or-odd-alist))) @@ -5898,7 +5898,7 @@ COMMAND.exe, COMMAND.bat and COMMAND.com in this order." ;; 5. Customize: (pr-insert-italic "\n\nCustomize : " 2 11) (pr-insert-button 'pr-customize "printing" " ") - (pr-insert-button #'(lambda (&rest _ignore) (ps-print-customize)) + (pr-insert-button (lambda (&rest _ignore) (ps-print-customize)) "ps-print" " ") (pr-insert-button 'lpr-customize "lpr")) @@ -6207,18 +6207,18 @@ COMMAND.exe, COMMAND.bat and COMMAND.com in this order." (defun pr-choice-alist (alist) - (let ((max (apply #'max (mapcar #'(lambda (alist) - (length (symbol-name (car alist)))) + (let ((max (apply #'max (mapcar (lambda (alist) + (length (symbol-name (car alist)))) alist)))) - (mapcar #'(lambda (alist) - (let* ((sym (car alist)) - (name (symbol-name sym))) - (list - 'choice-item - :format "%[%t%]" - :tag (concat name - (make-string (- max (length name)) ?_)) - :value sym))) + (mapcar (lambda (alist) + (let* ((sym (car alist)) + (name (symbol-name sym))) + (list + 'choice-item + :format "%[%t%]" + :tag (concat name + (make-string (- max (length name)) ?_)) + :value sym))) alist))) @@ -6227,5 +6227,4 @@ COMMAND.exe, COMMAND.bat and COMMAND.com in this order." (provide 'printing) - ;;; printing.el ends here commit e1f0da91abf1fbe093d55cda324ce1fe20fe3f12 Author: Stefan Kangas Date: Sun Apr 25 11:49:37 2021 +0200 * src/keyboard.c (Flossage_size): Improve prompt. diff --git a/src/keyboard.c b/src/keyboard.c index 5db45ce8e5..e9236fee1a 100644 --- a/src/keyboard.c +++ b/src/keyboard.c @@ -10379,7 +10379,7 @@ update_recent_keys (int new_size, int kept_keys) } DEFUN ("lossage-size", Flossage_size, Slossage_size, 0, 1, - "(list (read-number \"new-size: \" (lossage-size)))", + "(list (read-number \"Set maximum keystrokes to: \" (lossage-size)))", doc: /* Return or set the maximum number of keystrokes to save. If called with a non-nil ARG, set the limit to ARG and return it. Otherwise, return the current limit. commit 39bea8b59cd140ff72b63418631c24af84df3b57 Author: Stefan Kangas Date: Sun Apr 25 11:46:00 2021 +0200 Show correct lossage size in help-for-help * lisp/help.el (help-for-help): Show correct lossage size. Add trailing newline. Suggested by Gregory Heytings . diff --git a/lisp/help.el b/lisp/help.el index 4dcb2353ce..8234bbd34b 100644 --- a/lisp/help.el +++ b/lisp/help.el @@ -273,7 +273,8 @@ Do not call this in the scope of `with-help-window'." ("help-with-tutorial" "Start the Emacs tutorial") ("view-echo-area-messages" "Show recent messages (from echo area)") - ("view-lossage" "Show last 300 input keystrokes (lossage)") + ("view-lossage" (format "Show last %d input keystrokes (lossage)" + (lossage-size))) ("display-local-help" "Show local help at point")) ("Miscellaneous" ("about-emacs" "About Emacs") @@ -298,7 +299,8 @@ Do not call this in the scope of `with-help-window'." "Describe language environment") ("describe-syntax" "Show current syntax table") ("view-hello-file" - "Display the HELLO file illustrating various scripts"))))) + "Display the HELLO file illustrating various scripts")))) + "\n") help-map help-for-help-buffer-name) commit 7d5b973959d2ab056f685996ca156bf42b742dc6 (refs/remotes/origin/emacs-27) Author: Philipp Stephani Date: Sat Apr 24 23:29:58 2021 +0200 * doc/misc/cl.texi (For Clauses): Minor copyedits. diff --git a/doc/misc/cl.texi b/doc/misc/cl.texi index ea009a4e8e..f4147f9ea5 100644 --- a/doc/misc/cl.texi +++ b/doc/misc/cl.texi @@ -2092,14 +2092,15 @@ This clause also accepts optional @samp{from @var{pos}} and @samp{to @var{pos}} terms, limiting the clause to overlays which overlap the specified region. -@item for @var{var} being the intervals [of @var{buffer}] @dots{} -This clause iterates over all intervals of a buffer with constant -text properties. The variable @var{var} will be bound to conses -of start and end positions, where one start position is always equal -to the previous end position. The clause allows @code{of}, +@item for @var{var} being the intervals [of @var{object}] @dots{} +This clause iterates over all intervals of a buffer or string with +constant text properties. The variable @var{var} will be bound to +conses of start and end positions, where one start position is always +equal to the previous end position. The clause allows @code{of}, @code{from}, @code{to}, and @code{property} terms, where the latter term restricts the search to just the specified property. The -@code{of} term may specify either a buffer or a string. +@code{of} term may specify either a buffer or a string. @xref{Text +Properties,,,elisp}. @item for @var{var} being the frames This clause iterates over all Emacs frames. The clause @code{screens} is commit 4570781f8da1ca1273b0163299dfd9d6b9afc9c0 Author: Philipp Stephani Date: Sat Apr 24 23:22:44 2021 +0200 ; * doc/lispref/files.texi (Directory Names): Add missing parenthesis diff --git a/doc/lispref/files.texi b/doc/lispref/files.texi index 5310c8837d..4235c4900a 100644 --- a/doc/lispref/files.texi +++ b/doc/lispref/files.texi @@ -2215,7 +2215,7 @@ form. A @dfn{directory name} is a string that must name a directory if it names any file at all. A directory is actually a kind of file, and it -has a file name (called the @dfn{directory file name}, which is +has a file name (called the @dfn{directory file name}), which is related to the directory name but is typically not identical. (This is not quite the same as the usual POSIX terminology.) These two names for the same entity are related by a syntactic transformation. commit fa65c044f2ebe666467166075c1507a8d0e1347f (refs/remotes/origin/feature/native-comp) Author: Eli Zaretskii Date: Sat Apr 24 16:01:19 2021 +0300 Improve detection of pdumper file and *.eln files * src/emacs.c (load_pdump_find_executable): Resolve symlinks even if argv[0] includes leading directories. (Bug#46790) diff --git a/src/emacs.c b/src/emacs.c index 792f690797..9157cd84a9 100644 --- a/src/emacs.c +++ b/src/emacs.c @@ -746,10 +746,18 @@ load_pdump_find_executable (char const *argv0, ptrdiff_t *candidate_size) char *candidate = NULL; /* If the executable name contains a slash, we have some kind of - path already, so just copy it. */ + path already, so just resolve symlinks and return the result. */ eassert (argv0); if (strchr (argv0, DIRECTORY_SEP)) { + char *real_name = realpath (argv0, NULL); + + if (real_name) + { + *candidate_size = strlen (real_name) + 1; + return real_name; + } + char *val = xstrdup (argv0); *candidate_size = strlen (val) + 1; return val; commit 1b52fd538d6686b3d4f50c91c62be97910864c63 Author: Eli Zaretskii Date: Sat Apr 24 15:17:40 2021 +0300 Minor update for make-tarball.txt * admin/make-tarball.txt (UPDATING THE EMACS WEB PAGES AFTER A RELEASE): Update and enhance the section to make it easier to find the banner and verify the updated pages are in place. diff --git a/admin/make-tarball.txt b/admin/make-tarball.txt index fd63b7501b..dd3e504ddc 100644 --- a/admin/make-tarball.txt +++ b/admin/make-tarball.txt @@ -256,8 +256,9 @@ General steps (for each step, check for possible errors): UPDATING THE EMACS WEB PAGES AFTER A RELEASE -As soon as possible after a release, the Emacs web pages should be updated. -(See admin/notes/www for general information.) +As soon as possible after a release, the Emacs web pages at +https://www.gnu.org/software/emacs/ should be updated. (See +admin/notes/www for general information.) The pages to update are: @@ -267,7 +268,14 @@ add the new NEWS file as news/NEWS.xx.y For every new release, a banner is displayed on top of the emacs.html page. Uncomment and the release banner in emacs.html. Keep it on the -page for about a month, then comment it again. +page for about a month, then comment it again. The new release banner +looks like this: + +
+
+

Emacs 27.1 is out, download it here!

+
+
Regenerate the various manuals in manual/. The scripts admin/make-manuals and admin/upload-manuals summarize the process. commit 8efb8491b2d428e809c3d4263825250de21b2f97 Author: Jorge P. de Morais Neto Date: Thu Apr 22 20:16:33 2021 -0300 * doc/misc/cl.texi (Iteration Clauses): fix `never' clause typo This fixes bug#47962. Copyright-paperwork-exempt: yes diff --git a/doc/misc/cl.texi b/doc/misc/cl.texi index bcec3e4221..ea009a4e8e 100644 --- a/doc/misc/cl.texi +++ b/doc/misc/cl.texi @@ -2246,7 +2246,7 @@ were non-@code{nil}, the loop returns @code{t}: @item never @var{condition} This clause is like @code{always}, except that the loop returns -@code{t} if any conditions were false, or @code{nil} otherwise. +@code{t} if all conditions were false, or @code{nil} otherwise. @item thereis @var{condition} This clause stops the loop when the specified form is non-@code{nil}; commit 592ffd35b0de48f098fcf070d0a29bb3406e4bf9 Author: Eli Zaretskii Date: Sat Apr 24 11:20:50 2021 +0300 Improve diagnostics of loading *.eln files * src/pdumper.c (dump_do_dump_relocation): Improve diagnostics when loading preloaded *.eln files fails. (Bug#46790) diff --git a/src/pdumper.c b/src/pdumper.c index ed763a5d7e..dfc7388b63 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -5335,7 +5335,11 @@ dump_do_dump_relocation (const uintptr_t dump_base, comp_u->file = eln_fname; comp_u->handle = dynlib_open (SSDATA (eln_fname)); if (!comp_u->handle) - error ("%s", dynlib_error ()); + { + fprintf (stderr, "Error using execdir %s:\n", + emacs_execdir); + error ("%s", dynlib_error ()); + } load_comp_unit (comp_u, true, false); break; } commit 062e5994802bbe634bae7f1aef99f65daf1ec44e Author: Andrea Corallo Date: Thu Apr 22 09:57:30 2021 +0200 Improve a native compiler test * test/src/comp-tests.el (comp-test-47868-1): Improve testcase. * test/src/comp-test-funcs.el (comp-test-47868-3-f) (comp-test-47868-4-f): New functions. diff --git a/test/src/comp-test-funcs.el b/test/src/comp-test-funcs.el index 878db70609..f2a246320a 100644 --- a/test/src/comp-test-funcs.el +++ b/test/src/comp-test-funcs.el @@ -508,6 +508,12 @@ (defun comp-test-47868-2-f () #(" " 0 1 (face font-lock-keyword-face))) +(defun comp-test-47868-3-f () + " ") + +(defun comp-test-47868-4-f () + #(" " 0 1 (face font-lock-keyword-face))) + ;;;;;;;;;;;;;;;;;;;; diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index cb9032aa41..a1e91ec514 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -508,8 +508,13 @@ https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-03/msg00914.html." (should (equal (comp-test-46824-1-f) nil))) (comp-deftest comp-test-47868-1 () + "Verify string hash consing strategy. + +" (should-not (equal-including-properties (comp-test-47868-1-f) - (comp-test-47868-2-f)))) + (comp-test-47868-2-f))) + (should (eq (comp-test-47868-1-f) (comp-test-47868-3-f))) + (should (eq (comp-test-47868-2-f) (comp-test-47868-4-f)))) ;;;;;;;;;;;;;;;;;;;;; commit 606188a360111b6985f6615f96fb255330813aeb Author: Andrea Corallo Date: Wed Apr 21 23:15:56 2021 +0200 * lisp/emacs-lisp/comp.el (comp-imm-equal-test): Style fix. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 587618116f..ab5a06e7e8 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -731,8 +731,7 @@ Returns ELT." "Hash table lap-op -> stack adjustment.")) (define-hash-table-test 'comp-imm-equal-test #'equal-including-properties - (lambda (x) - (sxhash-equal-including-properties x))) + #'sxhash-equal-including-properties) (cl-defstruct comp-data-container "Data relocation container structure." commit de16621b5109f628c3ce41bdb15de6b29f540602 Author: Andrea Corallo Date: Wed Apr 21 15:23:33 2021 +0200 * lisp/emacs-lisp/comp.el (batch-byte-native-compile-for-bootstrap): Fix typo. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 394b8cb73c..587618116f 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -4166,7 +4166,7 @@ Native compilation equivalent to `batch-byte-compile'." ;;;###autoload (defun batch-byte-native-compile-for-bootstrap () - "Like `batch-native-compile', but used for booststrap. + "Like `batch-native-compile', but used for bootstrap. 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 `comp-eln-load-path'). commit f842816125c54a46eb786ff15622d88792e7677a Author: Andrea Corallo Date: Wed Apr 21 15:23:23 2021 +0200 Fix native compiler string hash consing strategy (bug#47868) * test/src/comp-tests.el (comp-test-47868-1): Add new test. * test/src/comp-test-funcs.el (comp-test-47868-1-f) (comp-test-47868-2-f): New functions. * lisp/emacs-lisp/comp.el (comp-imm-equal-test): Define new hash tanble test. (comp-data-container): Use it. (comp-final, comp-run-async-workers): have comp required before reading dumped hashes so that `comp-imm-equal-test' is defined. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 0122008fc9..394b8cb73c 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -730,11 +730,15 @@ Returns ELT." finally return h) "Hash table lap-op -> stack adjustment.")) +(define-hash-table-test 'comp-imm-equal-test #'equal-including-properties + (lambda (x) + (sxhash-equal-including-properties x))) + (cl-defstruct comp-data-container "Data relocation container structure." (l () :type list :documentation "Constant objects used by functions.") - (idx (make-hash-table :test #'equal) :type hash-table + (idx (make-hash-table :test 'comp-imm-equal-test) :type hash-table :documentation "Obj -> position into the previous field.")) (cl-defstruct (comp-ctxt (:include comp-cstr-ctxt)) @@ -3648,25 +3652,26 @@ Prepare every function for final compilation and drive the C back-end." (print-gensym t) (print-circle t) (print-escape-multibyte t) - (expr `(progn - (require 'comp) - (setf comp-verbose ,comp-verbose - comp-libgccjit-reproducer ,comp-libgccjit-reproducer - comp-ctxt ,comp-ctxt - comp-eln-load-path ',comp-eln-load-path - comp-native-driver-options - ',comp-native-driver-options - load-path ',load-path) - ,comp-async-env-modifier-form - (message "Compiling %s..." ',output) - (comp-final1))) + (expr `((require 'comp) + (setf comp-verbose ,comp-verbose + comp-libgccjit-reproducer ,comp-libgccjit-reproducer + comp-ctxt ,comp-ctxt + comp-eln-load-path ',comp-eln-load-path + comp-native-driver-options + ',comp-native-driver-options + load-path ',load-path) + ,comp-async-env-modifier-form + (message "Compiling %s..." ',output) + (comp-final1))) (temp-file (make-temp-file (concat "emacs-int-comp-" (file-name-base output) "-") nil ".el"))) (with-temp-file temp-file (insert ";; -*-coding: nil; -*-\n") - (insert (prin1-to-string expr))) + (mapc (lambda (e) + (insert (prin1-to-string e))) + expr)) (with-temp-buffer (unwind-protect (if (zerop @@ -3900,34 +3905,33 @@ display a message." ; commanded for late load. (file-newer-than-file-p source-file (comp-el-to-eln-filename source-file))) - do (let* ((expr `(progn - (require 'comp) - ,(when (boundp 'backtrace-line-length) - `(setf backtrace-line-length ,backtrace-line-length)) - (setf comp-speed ,comp-speed - comp-debug ,comp-debug - comp-verbose ,comp-verbose - comp-libgccjit-reproducer ,comp-libgccjit-reproducer - comp-async-compilation t - comp-eln-load-path ',comp-eln-load-path - comp-native-driver-options - ',comp-native-driver-options - load-path ',load-path - warning-fill-column most-positive-fixnum) - ,comp-async-env-modifier-form - (message "Compiling %s..." ,source-file) - (comp--native-compile ,source-file ,(and load t)))) + do (let* ((expr `((require 'comp) + ,(when (boundp 'backtrace-line-length) + `(setf backtrace-line-length ,backtrace-line-length)) + (setf comp-speed ,comp-speed + comp-debug ,comp-debug + comp-verbose ,comp-verbose + comp-libgccjit-reproducer ,comp-libgccjit-reproducer + comp-async-compilation t + comp-eln-load-path ',comp-eln-load-path + comp-native-driver-options + ',comp-native-driver-options + load-path ',load-path + warning-fill-column most-positive-fixnum) + ,comp-async-env-modifier-form + (message "Compiling %s..." ,source-file) + (comp--native-compile ,source-file ,(and load t)))) (source-file1 source-file) ;; Make the closure works :/ (temp-file (make-temp-file (concat "emacs-async-comp-" (file-name-base source-file) "-") nil ".el")) - (expr-string (prin1-to-string expr)) + (expr-strings (mapcar #'prin1-to-string expr)) (_ (progn (with-temp-file temp-file - (insert expr-string)) + (mapc #'insert expr-strings)) (comp-log "\n") - (comp-log expr-string))) + (mapc #'comp-log expr-strings))) (load1 load) (process (make-process :name (concat "Compiling: " source-file) diff --git a/test/src/comp-test-funcs.el b/test/src/comp-test-funcs.el index cbd0e5747e..878db70609 100644 --- a/test/src/comp-test-funcs.el +++ b/test/src/comp-test-funcs.el @@ -501,6 +501,14 @@ (format "%S" (error-message-string err)))))) (cl-return-from comp-test-46824-1-f)))) + +(defun comp-test-47868-1-f () + " ") + +(defun comp-test-47868-2-f () + #(" " 0 1 (face font-lock-keyword-face))) + + ;;;;;;;;;;;;;;;;;;;; ;; Tromey's tests ;; diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index b618110bbe..cb9032aa41 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -507,6 +507,10 @@ https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-03/msg00914.html." "" (should (equal (comp-test-46824-1-f) nil))) +(comp-deftest comp-test-47868-1 () + (should-not (equal-including-properties (comp-test-47868-1-f) + (comp-test-47868-2-f)))) + ;;;;;;;;;;;;;;;;;;;;; ;; Tromey's tests. ;; commit 0eee48af9de308ef57a065ecd8b2c2c7b59012a0 Author: Andrea Corallo Date: Wed Apr 21 14:22:11 2021 +0200 Introduce `sxhash-equal-including-properties'. * src/fns.c (collect_interval): Move it upwards. (Fsxhash_equal_including_properties): New function. (syms_of_fns): Register `sxhash-equal-including-properties'. * etc/NEWS: Add 'sxhash-equal-including-properties'. diff --git a/etc/NEWS b/etc/NEWS index fb0ec90fea..6928cbc429 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -2579,6 +2579,11 @@ the Emacs Lisp reference manual for background. * Lisp Changes in Emacs 28.1 ++++ +** New function 'sxhash-equal-including-properties'. +This is identical to 'sxhash-equal' but accounting also for string +properties. + +++ ** 'unlock-buffer' displays warnings instead of signaling. Instead of signaling 'file-error' conditions for file system level diff --git a/src/fns.c b/src/fns.c index 1758148ff2..41429c8863 100644 --- a/src/fns.c +++ b/src/fns.c @@ -4492,6 +4492,15 @@ check_mutable_hash_table (Lisp_Object obj, struct Lisp_Hash_Table *h) eassert (!PURE_P (h)); } +static void +collect_interval (INTERVAL interval, Lisp_Object collector) +{ + nconc2 (collector, + list1(list3 (make_fixnum (interval->position), + make_fixnum (interval->position + LENGTH (interval)), + interval->plist))); +} + /* Put an entry into hash table H that associates KEY with VALUE. HASH is a previously computed hash code of KEY. Value is the index of the entry in H matching KEY. */ @@ -4949,6 +4958,30 @@ Hash codes are not guaranteed to be preserved across Emacs sessions. */) return hashfn_equal (obj, NULL); } +DEFUN ("sxhash-equal-including-properties", Fsxhash_equal_including_properties, + Ssxhash_equal_including_properties, 1, 1, 0, + doc: /* Return an integer hash code for OBJ suitable for +`equal-including-properties'. +If (sxhash-equal-including-properties A B), then +(= (sxhash-equal-including-properties A) (sxhash-equal-including-properties B)). + +Hash codes are not guaranteed to be preserved across Emacs sessions. */) + (Lisp_Object obj) +{ + if (STRINGP (obj)) + { + Lisp_Object collector = Fcons (Qnil, Qnil); + traverse_intervals (string_intervals (obj), 0, collect_interval, + collector); + return + make_ufixnum ( + SXHASH_REDUCE (sxhash_combine (sxhash (obj), + sxhash (CDR (collector))))); + } + + return hashfn_equal (obj, NULL); +} + DEFUN ("make-hash-table", Fmake_hash_table, Smake_hash_table, 0, MANY, 0, doc: /* Create and return a new hash table. @@ -5832,15 +5865,6 @@ Case is always significant and text properties are ignored. */) return make_int (string_byte_to_char (haystack, res - SSDATA (haystack))); } -static void -collect_interval (INTERVAL interval, Lisp_Object collector) -{ - nconc2 (collector, - list1(list3 (make_fixnum (interval->position), - make_fixnum (interval->position + LENGTH (interval)), - interval->plist))); -} - DEFUN ("object-intervals", Fobject_intervals, Sobject_intervals, 1, 1, 0, doc: /* Return a copy of the text properties of OBJECT. OBJECT must be a buffer or a string. @@ -5922,6 +5946,7 @@ syms_of_fns (void) defsubr (&Ssxhash_eq); defsubr (&Ssxhash_eql); defsubr (&Ssxhash_equal); + defsubr (&Ssxhash_equal_including_properties); defsubr (&Smake_hash_table); defsubr (&Scopy_hash_table); defsubr (&Shash_table_count); commit 0873134682f0ef1309a71cc2c16d774edfadfe9f Author: Basil L. Contovounesios Date: Tue Apr 20 13:34:59 2021 +0100 ; Fix Texinfo in last change to minibuf.texi. diff --git a/doc/lispref/minibuf.texi b/doc/lispref/minibuf.texi index f16212abdc..3d07b0f17d 100644 --- a/doc/lispref/minibuf.texi +++ b/doc/lispref/minibuf.texi @@ -2154,7 +2154,7 @@ that is the question to ask the user. The function can also return The argument @var{actor} says how to act on the objects for which the user answers yes. It should be a function of one argument, and will -be called with each object from @var{LIST} for which the user answers +be called with each object from @var{list} for which the user answers yes. If the argument @var{help} is given, it should be a list of this form: commit cad8913c89fa2c15d6d6ac4fe0c63b6731981472 Author: Eli Zaretskii Date: Tue Apr 20 15:12:10 2021 +0300 Improve filling-related documentation * doc/emacs/text.texi (Auto Fill, Fill Commands): Mention special line-breaking rules for CJK characters and the kinsoku rules. (Bug#47856) * lisp/textmodes/fill.el (fill-separate-heterogeneous-words-with-space): Doc fix. diff --git a/doc/emacs/text.texi b/doc/emacs/text.texi index 208f8a19a9..2f924b4f7f 100644 --- a/doc/emacs/text.texi +++ b/doc/emacs/text.texi @@ -502,8 +502,8 @@ text. @cindex mode, Auto Fill @dfn{Auto Fill} mode is a buffer-local minor mode (@pxref{Minor -Modes}) in which lines are broken automatically at spaces when the -line becomes too wide. +Modes}) in which lines are broken automatically when the line becomes +too wide and you type @kbd{@key{SPC}} or @kbd{@key{RET}}. @table @kbd @item M-x auto-fill-mode @@ -522,12 +522,21 @@ certain major modes, add @code{auto-fill-mode} to the mode hooks (@pxref{Major Modes}). When Auto Fill mode is enabled, the mode indicator @samp{Fill} appears in the mode line (@pxref{Mode Line}). - Auto Fill mode breaks lines automatically at spaces whenever they -get longer than the desired width. This line breaking occurs only -when you type @key{SPC} or @key{RET}. If you wish to insert a space -or newline without permitting line-breaking, type @kbd{C-q @key{SPC}} -or @kbd{C-q C-j} respectively. Also, @kbd{C-o} inserts a newline -without line breaking. + Auto Fill mode breaks lines automatically at the appropriate places +whenever lines get longer than the desired width. This line breaking +occurs only when you type @kbd{@key{SPC}} or @kbd{@key{RET}}. If you +wish to insert a space or newline without permitting line-breaking, +type @kbd{C-q @key{SPC}} or @kbd{C-q C-j} respectively. Also, +@kbd{C-o} inserts a newline without line breaking. + +@cindex kinsoku line-breaking rules + The place where Auto Fill breaks a line depends on the line's +characters. For characters from @acronym{ASCII}, Latin, and most +other scripts Emacs breaks a line on space characters, to keep the +words intact. But for CJK scripts, a line can be broken between any +two characters. (If you load the @file{kinsoku} library, Emacs will +avoid breaking a line between certain pairs of CJK characters, where +special rules prohibit that.) When Auto Fill mode breaks a line, it tries to obey the @dfn{adaptive fill prefix}: if a fill prefix can be deduced from the @@ -549,6 +558,9 @@ described in the next section. (@pxref{Fill Commands}). @end ifnottex + A similar feature that wraps long lines automatically at display +time is Visual Line Mode (@pxref{Visual Line Mode}). + @node Fill Commands @subsection Explicit Fill Commands @@ -571,7 +583,11 @@ Center a line. current paragraph. It redistributes the line breaks within the paragraph, and deletes any excess space and tab characters occurring within the paragraph, in such a way that the lines end up fitting -within a certain maximum width. +within a certain maximum width. Like Auto Fill mode, this and other +filling commands usually break lines at space characters, but for CJK +characters these commands can break a line between almost any two +characters, and they can also obey the kinsoku rules. @xref{Auto +Fill}. @findex fill-region Normally, @kbd{M-q} acts on the paragraph where point is, but if @@ -645,8 +661,8 @@ or before @samp{)}, @samp{:} or @samp{?}); and even if preceded by a non-whitespace character). Emacs can display an indicator in the @code{fill-column} position -using the Display fill column indicator mode -(@pxref{Displaying Boundaries, display-fill-column-indicator}). +using the Display fill column indicator mode (@pxref{Displaying +Boundaries, display-fill-column-indicator}). @node Fill Prefix @subsection The Fill Prefix diff --git a/lisp/textmodes/fill.el b/lisp/textmodes/fill.el index e9bef6ec80..6d283bd6f1 100644 --- a/lisp/textmodes/fill.el +++ b/lisp/textmodes/fill.el @@ -51,10 +51,12 @@ A value of nil means that any change in indentation starts a new paragraph." (defcustom fill-separate-heterogeneous-words-with-space nil "Non-nil means to use a space to separate words of a different kind. -This will be done with a word in the end of a line and a word in -the beginning of the next line when concatenating them for -filling those lines. Whether to use a space depends on how the -words are categorized." +For example, when an English word at the end of a line and a CJK word +at the beginning of the next line are joined into a single line, they +will be separated by a space if this variable is non-nil. +Whether to use a space to separate such words also depends on the entry +in `fill-nospace-between-words-table' for the characters before and +after the newline." :type 'boolean :group 'fill :version "26.1") commit b5c76530fab4b99e76249bfb9a105b30bef4ce67 Merge: e54066f3d4 0a4dc70830 Author: Andrea Corallo Date: Mon Apr 19 18:46:50 2021 +0200 Merge remote-tracking branch 'savannah/master' into native-comp commit e54066f3d459f67a1ee4e44552bf0356d010e03f Author: Eli Zaretskii Date: Sun Apr 18 22:36:01 2021 +0300 * src/emacs.c (main): Add back the call to init_callproc_1. (bug#47872) diff --git a/src/emacs.c b/src/emacs.c index c09ad97a70..792f690797 100644 --- a/src/emacs.c +++ b/src/emacs.c @@ -2011,6 +2011,9 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem /* Init buffer storage and default directory of main buffer. */ init_buffer (); + /* Must precede init_cmdargs and init_sys_modes. */ + init_callproc_1 (); + /* Must precede init_lread. */ init_cmdargs (argc, argv, skip_args, original_pwd); commit 490b8c2c339966886190fdf897e2d95fb4bb5e3b Author: Eli Zaretskii Date: Sun Apr 18 16:44:44 2021 +0300 * src/comp.c (fixup_eln_load_path): Simplify code. diff --git a/src/comp.c b/src/comp.c index 50947316df..5309be46de 100644 --- a/src/comp.c +++ b/src/comp.c @@ -4760,14 +4760,12 @@ fixup_eln_load_path (Lisp_Object eln_filename) if (CONSP (tem)) last_cell = tem; - const char preloaded[] = "preloaded"; - ptrdiff_t preloaded_len = sizeof (preloaded) - 1; + const char preloaded[] = "/preloaded/"; Lisp_Object eln_cache_sys = Ffile_name_directory (eln_filename); - bool preloaded_p = - !NILP (Fequal (Fsubstring_no_properties (eln_cache_sys, - make_fixnum (-preloaded_len - 1), - make_fixnum (-1)), - build_string (preloaded))); + const char *p_preloaded = + SSDATA (eln_cache_sys) + SBYTES (eln_cache_sys) - sizeof (preloaded) + 1; + bool preloaded_p = strcmp (p_preloaded, preloaded) == 0; + /* One or two directories up... */ for (int i = 0; i < (preloaded_p ? 2 : 1); i++) eln_cache_sys = commit cc2d2e8d6c7d52d2fbbf9ffe410f97952c64cb3e Author: Eli Zaretskii Date: Sun Apr 18 14:56:00 2021 +0300 ; * src/emacs.c (load_pdump_find_executable): Yet another fix. diff --git a/src/emacs.c b/src/emacs.c index 922da9f1da..c09ad97a70 100644 --- a/src/emacs.c +++ b/src/emacs.c @@ -749,7 +749,11 @@ load_pdump_find_executable (char const *argv0, ptrdiff_t *candidate_size) path already, so just copy it. */ eassert (argv0); if (strchr (argv0, DIRECTORY_SEP)) - return xstrdup (argv0); + { + char *val = xstrdup (argv0); + *candidate_size = strlen (val) + 1; + return val; + } ptrdiff_t argv0_length = strlen (argv0); const char *path = getenv ("PATH"); commit af0af63742fd2383dae5627d0ce8167517fd4700 Author: Eli Zaretskii Date: Sun Apr 18 12:00:25 2021 +0300 Fix last change * src/emacs.c (load_pdump_find_executable): Fix the value of CANDIDATE_SIZE when the final candidate is a symlink. diff --git a/src/emacs.c b/src/emacs.c index 896e129c75..922da9f1da 100644 --- a/src/emacs.c +++ b/src/emacs.c @@ -795,7 +795,10 @@ load_pdump_find_executable (char const *argv0, ptrdiff_t *candidate_size) char *real_name = realpath (candidate, NULL); if (real_name) - return real_name; + { + *candidate_size = strlen (real_name) + 1; + return real_name; + } } return candidate; } commit 2b7eed23eb3aff338b737cce91d22bb464259a1a Author: Philipp Stephani Date: Sat Apr 17 23:13:57 2021 +0200 ; * doc/lispref/keymaps.texi (Easy Menu): Fix typo. diff --git a/doc/lispref/keymaps.texi b/doc/lispref/keymaps.texi index d6dcc432f8..3cfb2b62b1 100644 --- a/doc/lispref/keymaps.texi +++ b/doc/lispref/keymaps.texi @@ -2924,7 +2924,7 @@ menu item. @item :active @var{enable} @var{enable} is an expression; if it evaluates to @code{nil}, the item -is make unselectable.. @code{:enable} is an alias for @code{:active}. +is made unselectable. @code{:enable} is an alias for @code{:active}. @item :visible @var{include} @var{include} is an expression; if it evaluates to @code{nil}, the commit 75c898edc3d7e06b589ce42917ae56e0c40082ac Author: Eli Zaretskii Date: Sat Apr 17 19:10:16 2021 +0300 ; * src/pdumper.c (dump_do_dump_relocation): Add a FIXME comment. diff --git a/src/pdumper.c b/src/pdumper.c index c9285ddbc7..ed763a5d7e 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -5325,6 +5325,13 @@ dump_do_dump_relocation (const uintptr_t dump_base, memcpy (fndata + execdir_len, SSDATA (cu_file), fn_len); } + /* FIXME: This records the names of the *.eln files in an + unexpanded form, with one or more ".." elements (and on + Windows with the first part using backslashes). The file + names are also unibyte. If we care about this, we need to + loop in startup.el over all the preloaded modules and run + their file names through expand-file-name and + decode-coding-string. */ comp_u->file = eln_fname; comp_u->handle = dynlib_open (SSDATA (eln_fname)); if (!comp_u->handle) commit b8d386083f8f0a0f7ec16f43055cc9f557f6a7f3 Author: Eli Zaretskii Date: Sat Apr 17 18:10:52 2021 +0300 * src/emacs.c (load_pdump): Fix unconditional references to strip_suffix. diff --git a/src/emacs.c b/src/emacs.c index 2fc93631c9..896e129c75 100644 --- a/src/emacs.c +++ b/src/emacs.c @@ -917,7 +917,8 @@ load_pdump (int argc, char **argv) /* Assume the Emacs binary lives in a sibling directory as set up by the default installation configuration. */ const char *go_up = "../../../../bin/"; - needed += strlen (strip_suffix) - strlen (suffix) + strlen (go_up); + needed += (strip_suffix ? strlen (strip_suffix) : 0) + - strlen (suffix) + strlen (go_up); if (exec_bufsize < needed) { xfree (emacs_executable); @@ -925,7 +926,8 @@ load_pdump (int argc, char **argv) -1, 1); } sprintf (emacs_executable, "%s%c%s%s%s", - path_exec, DIRECTORY_SEP, go_up, argv0_base, strip_suffix); + path_exec, DIRECTORY_SEP, go_up, argv0_base, + strip_suffix ? strip_suffix : ""); result = pdumper_load (dump_file, emacs_executable); if (result == PDUMPER_LOAD_FILE_NOT_FOUND) commit cb4c41f0621887172f4ababbbe65ceadb01581ec Author: Eli Zaretskii Date: Sat Apr 17 17:29:17 2021 +0300 * emacs.c (load_pdump): Fix compilation on picky-complier platforms. diff --git a/src/emacs.c b/src/emacs.c index d27b1c1351..2fc93631c9 100644 --- a/src/emacs.c +++ b/src/emacs.c @@ -820,6 +820,7 @@ load_pdump (int argc, char **argv) NULL #endif ; + const char *argv0_base = "emacs"; /* TODO: maybe more thoroughly scrub process environment in order to make this use case (loading a dump file in an unexeced emacs) @@ -891,6 +892,7 @@ load_pdump (int argc, char **argv) dump_file, dump_error_to_string (result)); hardcoded: + #ifdef WINDOWSNT /* On MS-Windows, PATH_EXEC normally starts with a literal "%emacs_dir%", so it will never work without some tweaking. */ @@ -900,7 +902,6 @@ load_pdump (int argc, char **argv) /* Look for "emacs.pdmp" in PATH_EXEC. We hardcode "emacs" in "emacs.pdmp" so that the Emacs binary still works if the user copies and renames it. */ - const char *argv0_base = "emacs"; needed = (strlen (path_exec) + 1 + strlen (argv0_base) commit 47fc92cefc8349fe558e6dbba2a6e46502e4e17e Author: Daniel Martín Date: Sat Apr 17 13:18:45 2021 +0200 Fix reference to "yanking" in the main Emacs manual * doc/emacs/emacs.texi (Top): Yanking is alternatively known as pasting, not copying. (Bug#47839). diff --git a/doc/emacs/emacs.texi b/doc/emacs/emacs.texi index 22e19aee63..4481ac9045 100644 --- a/doc/emacs/emacs.texi +++ b/doc/emacs/emacs.texi @@ -159,7 +159,7 @@ Fundamental Editing Commands Important Text-Changing Commands * Mark:: The mark: how to delimit a region of text. -* Killing:: Killing (cutting) and yanking (copying) text. +* Killing:: Killing (cutting) and yanking (pasting) text. * Registers:: Saving a text string or a location in the buffer. * Display:: Controlling what text is displayed. * Search:: Finding or replacing occurrences of a string. commit 9aa5203b542f0c9ea7d074c6cfde2a28b466f5d1 Author: Eli Zaretskii Date: Sat Apr 17 16:49:16 2021 +0300 Fix loading *.eln files when Emacs is installed via symlinks * src/emacs.c (real_filename, set_invocation_vars) (init_vars_for_load): Functions deleted; callers adjusted. (init_cmdargs): Put back all the code which was extracted into set_invocation_vars. (load_pdump_find_executable): Make sure the return value has any symlinks in it expanded. (load_pdump): Accept only 2 arguments, not 3. Determine both the file name of the Emacs executable and of the dump file in synchronized manner, so that if we decided to look for the dump file in its hardcoded installation directory, the directory of the Emacs executable will also be where we expect it to be installed. Pass only 2 arguments to pdumper_load. (Bug#47800) (Bug#44128) * src/pdumper.c (dump_do_dump_relocation): Use emacs_execdir instead of Vinvocation_directory to produce absolute file names of *.eln files that are recorded in the pdumper file. Pass the full .eln file name to fixup_eln_load_path. (pdumper_set_emacs_execdir) [HAVE_NATIVE_COMP]: New function. (pdumper_load) [HAVE_NATIVE_COMP]: Call pdumper_set_emacs_execdir. * src/comp.c (fixup_eln_load_path): Use Fsubstring_no_properties instead of Fsubstring. No need to cons a file name, as the caller already did that. Use explicit const string to avoid "magic" values. * lisp/startup.el (normal-top-level): Use expand-file-name instead of concat. Decode comp-eln-load-path and expand-file-name its members. diff --git a/lisp/startup.el b/lisp/startup.el index 6e0faf3f68..01d2814165 100644 --- a/lisp/startup.el +++ b/lisp/startup.el @@ -544,7 +544,8 @@ It is the default value of the variable `top-level'." (dolist (path (split-string path-env path-separator)) (unless (string= "" path) (push path comp-eln-load-path))))) - (push (concat user-emacs-directory "eln-cache/") comp-eln-load-path) + (push (expand-file-name "eln-cache/" user-emacs-directory) + comp-eln-load-path) ;; When $HOME is set to '/nonexistent' means we are running the ;; testsuite, add a temporary folder in front to produce there ;; new compilations. @@ -636,6 +637,16 @@ It is the default value of the variable `top-level'." (set pathsym (mapcar (lambda (dir) (decode-coding-string dir coding t)) path))))) + (when (featurep 'nativecomp) + (let ((npath (symbol-value 'comp-eln-load-path))) + (set 'comp-eln-load-path + (mapcar (lambda (dir) + ;; Call expand-file-name to remove all the + ;; pesky ".." from the directyory names in + ;; comp-eln-load-path. + (expand-file-name + (decode-coding-string dir coding t))) + npath)))) (dolist (filesym '(data-directory doc-directory exec-directory installation-directory invocation-directory invocation-name diff --git a/src/comp.c b/src/comp.c index c4b9b4b6c1..50947316df 100644 --- a/src/comp.c +++ b/src/comp.c @@ -4749,29 +4749,30 @@ maybe_defer_native_compilation (Lisp_Object function_name, /* Functions used to load eln files. */ /**************************************/ -/* Fixup the system eln-cache dir. This is the last entry in - `comp-eln-load-path'. */ +/* Fixup the system eln-cache directory, which is the last entry in + `comp-eln-load-path'. Argument is a .eln file in that directory. */ void fixup_eln_load_path (Lisp_Object eln_filename) { Lisp_Object last_cell = Qnil; - Lisp_Object tmp = Vcomp_eln_load_path; - FOR_EACH_TAIL (tmp) - if (CONSP (tmp)) - last_cell = tmp; - - Lisp_Object eln_cache_sys = - Ffile_name_directory (concat2 (Vinvocation_directory, - eln_filename)); - bool preloaded = - !NILP (Fequal (Fsubstring (eln_cache_sys, make_fixnum (-10), - make_fixnum (-1)), - build_string ("preloaded"))); + Lisp_Object tem = Vcomp_eln_load_path; + FOR_EACH_TAIL (tem) + if (CONSP (tem)) + last_cell = tem; + + const char preloaded[] = "preloaded"; + ptrdiff_t preloaded_len = sizeof (preloaded) - 1; + Lisp_Object eln_cache_sys = Ffile_name_directory (eln_filename); + bool preloaded_p = + !NILP (Fequal (Fsubstring_no_properties (eln_cache_sys, + make_fixnum (-preloaded_len - 1), + make_fixnum (-1)), + build_string (preloaded))); /* One or two directories up... */ - for (int i = 0; i < (preloaded ? 2 : 1); i++) + for (int i = 0; i < (preloaded_p ? 2 : 1); i++) eln_cache_sys = - Ffile_name_directory (Fsubstring (eln_cache_sys, Qnil, - make_fixnum (-1))); + Ffile_name_directory (Fsubstring_no_properties (eln_cache_sys, Qnil, + make_fixnum (-1))); Fsetcar (last_cell, eln_cache_sys); } diff --git a/src/comp.h b/src/comp.h index e17b843d13..03d22dfaa0 100644 --- a/src/comp.h +++ b/src/comp.h @@ -34,7 +34,11 @@ enum { struct Lisp_Native_Comp_Unit { union vectorlike_header header; - /* Original eln file loaded. */ + /* The original eln file loaded. In the pdumper file this is stored + as a cons cell of 2 alternative file names: the car is the + filename relative to the directory of an installed binary, the + cdr is the filename relative to the directory of an uninstalled + binary. This is arranged in loadup.el. */ Lisp_Object file; Lisp_Object optimize_qualities; /* Guard anonymous lambdas against Garbage Collection and serve diff --git a/src/emacs.c b/src/emacs.c index a2565645c6..d27b1c1351 100644 --- a/src/emacs.c +++ b/src/emacs.c @@ -440,53 +440,33 @@ terminate_due_to_signal (int sig, int backtrace_limit) exit (1); } -/* Return the real filename following symlinks in case. - The caller should deallocate the returned buffer. */ - -static char * -real_filename (char *filename) -{ - char *real_name; -#ifdef WINDOWSNT - /* w32_my_exename resolves symlinks internally, so no need to - call realpath. */ - real_name = xstrdup (filename); -#else - real_name = realpath (filename, NULL); - if (!real_name) - fatal ("could not resolve realpath of \"%s\": %s", - filename, strerror (errno)); -#endif - return real_name; -} - -/* Set `invocation-name' `invocation-directory'. */ - + +/* Code for dealing with Lisp access to the Unix command line. */ static void -set_invocation_vars (char *argv0, char const *original_pwd) +init_cmdargs (int argc, char **argv, int skip_args, char const *original_pwd) { - Lisp_Object raw_name, handler; + int i; + Lisp_Object name, dir, handler; + ptrdiff_t count = SPECPDL_INDEX (); + Lisp_Object raw_name; AUTO_STRING (slash_colon, "/:"); + initial_argv = argv; + initial_argc = argc; + #ifdef WINDOWSNT - /* Must use argv0 converted to UTF-8, as it begets many standard + /* Must use argv[0] converted to UTF-8, as it begets many standard file and directory names. */ { - char argv0_1[MAX_UTF8_PATH]; + char argv0[MAX_UTF8_PATH]; - /* Avoid calling 'openp' below, as we aren't ready for that yet: - emacs_dir is not yet defined in the environment, and therefore - emacs_root_dir, called by expand-file-name, will abort. */ - if (!IS_ABSOLUTE_FILE_NAME (argv0)) - argv0 = w32_my_exename (); - - if (filename_from_ansi (argv0, argv0_1) == 0) - raw_name = build_unibyte_string (argv0_1); - else + if (filename_from_ansi (argv[0], argv0) == 0) raw_name = build_unibyte_string (argv0); + else + raw_name = build_unibyte_string (argv[0]); } #else - raw_name = build_unibyte_string (argv0); + raw_name = build_unibyte_string (argv[0]); #endif /* Add /: to the front of the name @@ -495,26 +475,16 @@ set_invocation_vars (char *argv0, char const *original_pwd) if (! NILP (handler)) raw_name = concat2 (slash_colon, raw_name); - char *filename = real_filename (SSDATA (raw_name)); - raw_name = build_unibyte_string (filename); - xfree (filename); - Vinvocation_name = Ffile_name_nondirectory (raw_name); Vinvocation_directory = Ffile_name_directory (raw_name); -#ifdef WINDOWSNT - eassert (!NILP (Vinvocation_directory) - && !NILP (Ffile_name_absolute_p (Vinvocation_directory))); -#endif - - /* If we got no directory in argv0, search PATH to find where + /* If we got no directory in argv[0], search PATH to find where Emacs actually came from. */ if (NILP (Vinvocation_directory)) { Lisp_Object found; - int yes = - openp (Vexec_path, Vinvocation_name, Vexec_suffixes, &found, - make_fixnum (X_OK), false, false); + int yes = openp (Vexec_path, Vinvocation_name, Vexec_suffixes, + &found, make_fixnum (X_OK), false, false); if (yes == 1) { /* Add /: to the front of the name @@ -536,38 +506,6 @@ set_invocation_vars (char *argv0, char const *original_pwd) Vinvocation_directory = Fexpand_file_name (Vinvocation_directory, odir); } -} - -/* Initialize a number of variables (ultimately - 'Vinvocation_directory') needed by pdumper to complete native code - load. */ - -void -init_vars_for_load (char *argv0, char const *original_pwd) -{ - /* This function is called from within pdumper while loading (as - soon as we are able to allocate) or later during boot if pdumper - is not used. No need to run it twice. */ - static bool double_run_guard; - if (double_run_guard) - return; - double_run_guard = true; - - init_callproc_1 (); /* Must precede init_cmdargs and init_sys_modes. */ - set_invocation_vars (argv0, original_pwd); -} - - -/* Code for dealing with Lisp access to the Unix command line. */ -static void -init_cmdargs (int argc, char **argv, int skip_args, char const *original_pwd) -{ - int i; - Lisp_Object name, dir; - ptrdiff_t count = SPECPDL_INDEX (); - - initial_argv = argv; - initial_argc = argc; Vinstallation_directory = Qnil; @@ -801,6 +739,8 @@ load_pdump_find_executable (char const *argv0, ptrdiff_t *candidate_size) implementation of malloc, since the caller calls our free. */ #ifdef WINDOWSNT char *prog_fname = w32_my_exename (); + if (prog_fname) + *candidate_size = strlen (prog_fname) + 1; return prog_fname ? xstrdup (prog_fname) : NULL; #else /* !WINDOWSNT */ char *candidate = NULL; @@ -846,7 +786,19 @@ load_pdump_find_executable (char const *argv0, ptrdiff_t *candidate_size) struct stat st; if (file_access_p (candidate, X_OK) && stat (candidate, &st) == 0 && S_ISREG (st.st_mode)) - return candidate; + { + /* People put on PATH a symlink to the real Emacs + executable, with all the auxiliary files where the real + executable lives. Support that. */ + if (lstat (candidate, &st) == 0 && S_ISLNK (st.st_mode)) + { + char *real_name = realpath (candidate, NULL); + + if (real_name) + return real_name; + } + return candidate; + } *candidate = '\0'; } while (*path++ != '\0'); @@ -856,10 +808,11 @@ load_pdump_find_executable (char const *argv0, ptrdiff_t *candidate_size) } static void -load_pdump (int argc, char **argv, char const *original_pwd) +load_pdump (int argc, char **argv) { const char *const suffix = ".pdmp"; int result; + char *emacs_executable = argv[0]; const char *strip_suffix = #if defined DOS_NT || defined CYGWIN ".exe" @@ -889,9 +842,19 @@ load_pdump (int argc, char **argv, char const *original_pwd) skip_args++; } + /* Where's our executable? */ + ptrdiff_t bufsize, exec_bufsize; + emacs_executable = load_pdump_find_executable (argv[0], &bufsize); + exec_bufsize = bufsize; + + /* If we couldn't find our executable, go straight to looking for + the dump in the hardcoded location. */ + if (!(emacs_executable && *emacs_executable)) + goto hardcoded; + if (dump_file) { - result = pdumper_load (dump_file, argv[0], original_pwd); + result = pdumper_load (dump_file, emacs_executable); if (result != PDUMPER_LOAD_SUCCESS) fatal ("could not load dump file \"%s\": %s", @@ -905,42 +868,29 @@ load_pdump (int argc, char **argv, char const *original_pwd) so we can't use decode_env_path. We're working in whatever encoding the system natively uses for filesystem access, so there's no need for character set conversion. */ - ptrdiff_t bufsize; - dump_file = load_pdump_find_executable (argv[0], &bufsize); - - /* If we couldn't find our executable, go straight to looking for - the dump in the hardcoded location. */ - if (dump_file && *dump_file) - { - char *real_exename = real_filename (dump_file); - xfree (dump_file); - dump_file = real_exename; - ptrdiff_t exenamelen = strlen (dump_file); -#ifndef WINDOWSNT - bufsize = exenamelen + 1; -#endif - if (strip_suffix) - { - ptrdiff_t strip_suffix_length = strlen (strip_suffix); - ptrdiff_t prefix_length = exenamelen - strip_suffix_length; - if (0 <= prefix_length - && !memcmp (&dump_file[prefix_length], strip_suffix, - strip_suffix_length)) - exenamelen = prefix_length; - } - ptrdiff_t needed = exenamelen + strlen (suffix) + 1; - if (bufsize < needed) - dump_file = xpalloc (dump_file, &bufsize, needed - bufsize, -1, 1); - strcpy (dump_file + exenamelen, suffix); - result = pdumper_load (dump_file, argv[0], original_pwd); - if (result == PDUMPER_LOAD_SUCCESS) - goto out; - - if (result != PDUMPER_LOAD_FILE_NOT_FOUND) - fatal ("could not load dump file \"%s\": %s", - dump_file, dump_error_to_string (result)); - } - + ptrdiff_t exenamelen = strlen (emacs_executable); + if (strip_suffix) + { + ptrdiff_t strip_suffix_length = strlen (strip_suffix); + ptrdiff_t prefix_length = exenamelen - strip_suffix_length; + if (0 <= prefix_length + && !memcmp (&emacs_executable[prefix_length], strip_suffix, + strip_suffix_length)) + exenamelen = prefix_length; + } + ptrdiff_t needed = exenamelen + strlen (suffix) + 1; + dump_file = xpalloc (NULL, &bufsize, needed - bufsize, -1, 1); + memcpy (dump_file, emacs_executable, exenamelen); + strcpy (dump_file + exenamelen, suffix); + result = pdumper_load (dump_file, emacs_executable); + if (result == PDUMPER_LOAD_SUCCESS) + goto out; + + if (result != PDUMPER_LOAD_FILE_NOT_FOUND) + fatal ("could not load dump file \"%s\": %s", + dump_file, dump_error_to_string (result)); + + hardcoded: #ifdef WINDOWSNT /* On MS-Windows, PATH_EXEC normally starts with a literal "%emacs_dir%", so it will never work without some tweaking. */ @@ -951,11 +901,11 @@ load_pdump (int argc, char **argv, char const *original_pwd) "emacs.pdmp" so that the Emacs binary still works if the user copies and renames it. */ const char *argv0_base = "emacs"; - ptrdiff_t needed = (strlen (path_exec) - + 1 - + strlen (argv0_base) - + strlen (suffix) - + 1); + needed = (strlen (path_exec) + + 1 + + strlen (argv0_base) + + strlen (suffix) + + 1); if (bufsize < needed) { xfree (dump_file); @@ -963,7 +913,19 @@ load_pdump (int argc, char **argv, char const *original_pwd) } sprintf (dump_file, "%s%c%s%s", path_exec, DIRECTORY_SEP, argv0_base, suffix); - result = pdumper_load (dump_file, argv[0], original_pwd); + /* Assume the Emacs binary lives in a sibling directory as set up by + the default installation configuration. */ + const char *go_up = "../../../../bin/"; + needed += strlen (strip_suffix) - strlen (suffix) + strlen (go_up); + if (exec_bufsize < needed) + { + xfree (emacs_executable); + emacs_executable = xpalloc (NULL, &exec_bufsize, needed - exec_bufsize, + -1, 1); + } + sprintf (emacs_executable, "%s%c%s%s%s", + path_exec, DIRECTORY_SEP, go_up, argv0_base, strip_suffix); + result = pdumper_load (dump_file, emacs_executable); if (result == PDUMPER_LOAD_FILE_NOT_FOUND) { @@ -998,7 +960,7 @@ load_pdump (int argc, char **argv, char const *original_pwd) #endif sprintf (dump_file, "%s%c%s%s", path_exec, DIRECTORY_SEP, argv0_base, suffix); - result = pdumper_load (dump_file, argv[0], original_pwd); + result = pdumper_load (dump_file, emacs_executable); } if (result != PDUMPER_LOAD_SUCCESS) @@ -1010,6 +972,7 @@ load_pdump (int argc, char **argv, char const *original_pwd) out: xfree (dump_file); + xfree (emacs_executable); } #endif /* HAVE_PDUMPER */ @@ -1320,10 +1283,9 @@ main (int argc, char **argv) w32_init_main_thread (); #endif - emacs_wd = emacs_get_current_dir_name (); #ifdef HAVE_PDUMPER if (attempt_load_pdump) - load_pdump (argc, argv, emacs_wd); + load_pdump (argc, argv); #endif argc = maybe_disable_address_randomization (argc, argv); @@ -1395,6 +1357,7 @@ main (int argc, char **argv) exit (0); } + emacs_wd = emacs_get_current_dir_name (); #ifdef HAVE_PDUMPER if (dumped_with_pdumper_p ()) pdumper_record_wd (emacs_wd); @@ -2038,8 +2001,6 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem /* Init buffer storage and default directory of main buffer. */ init_buffer (); - init_vars_for_load (argv[0], original_pwd); - /* Must precede init_lread. */ init_cmdargs (argc, argv, skip_args, original_pwd); diff --git a/src/lisp.h b/src/lisp.h index 474e49c8e1..f83c55f827 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -4450,7 +4450,6 @@ extern bool display_arg; extern Lisp_Object decode_env_path (const char *, const char *, bool); extern Lisp_Object empty_unibyte_string, empty_multibyte_string; extern AVOID terminate_due_to_signal (int, int); -extern void init_vars_for_load (char *, char const *); #ifdef WINDOWSNT extern Lisp_Object Vlibrary_cache; #endif diff --git a/src/pdumper.c b/src/pdumper.c index dc893c59bf..c9285ddbc7 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -4356,6 +4356,16 @@ pdumper_remember_lv_ptr_raw_impl (void *ptr, enum Lisp_Type type) } +#ifdef HAVE_NATIVE_COMP +/* This records the directory where the Emacs executable lives, to be + used for locating the native-lisp directory from which we need to + load the preloaded *.eln files. See pdumper_set_emacs_execdir + below. */ +static char *emacs_execdir; +static ptrdiff_t execdir_size; +static ptrdiff_t execdir_len; +#endif + /* Dump runtime */ enum dump_memory_protection { @@ -5269,35 +5279,54 @@ dump_do_dump_relocation (const uintptr_t dump_base, struct Lisp_Native_Comp_Unit *comp_u = dump_ptr (dump_base, reloc_offset); comp_u->lambda_gc_guard_h = CALLN (Fmake_hash_table, QCtest, Qeq); - if (!CONSP (comp_u->file)) + if (STRINGP (comp_u->file)) error ("Trying to load incoherent dumped eln file %s", SSDATA (comp_u->file)); + /* emacs_execdir is always unibyte, but the file names in + comp_u->file could be multibyte, so we need to encode + them. */ + Lisp_Object cu_file1 = ENCODE_FILE (XCAR (comp_u->file)); + Lisp_Object cu_file2 = ENCODE_FILE (XCDR (comp_u->file)); + ptrdiff_t fn1_len = SBYTES (cu_file1), fn2_len = SBYTES (cu_file2); + Lisp_Object eln_fname; + char *fndata; + /* Check just once if this is a local build or Emacs was installed. */ + /* Can't use expand-file-name here, because we are too early + in the startup, and we will crash at least on WINDOWSNT. */ if (installation_state == UNKNOWN) { - /* Can't use expand-file-name here, because we are too - early in the startup, and we will crash at least on - WINDOWSNT. */ - Lisp_Object fname = - concat2 (Vinvocation_directory, XCAR (comp_u->file)); - if (file_access_p (SSDATA (ENCODE_FILE (fname)), F_OK)) - { - installation_state = INSTALLED; - fixup_eln_load_path (XCAR (comp_u->file)); - } + eln_fname = make_uninit_string (execdir_len + fn1_len); + fndata = SSDATA (eln_fname); + memcpy (fndata, emacs_execdir, execdir_len); + memcpy (fndata + execdir_len, SSDATA (cu_file1), fn1_len); + if (file_access_p (fndata, F_OK)) + installation_state = INSTALLED; else { + eln_fname = make_uninit_string (execdir_len + fn2_len); + fndata = SSDATA (eln_fname); + memcpy (fndata, emacs_execdir, execdir_len); + memcpy (fndata + execdir_len, SSDATA (cu_file2), fn2_len); installation_state = LOCAL_BUILD; - fixup_eln_load_path (XCDR (comp_u->file)); } + fixup_eln_load_path (eln_fname); + } + else + { + ptrdiff_t fn_len = + installation_state == INSTALLED ? fn1_len : fn2_len; + Lisp_Object cu_file = + installation_state == INSTALLED ? cu_file1 : cu_file2; + eln_fname = make_uninit_string (execdir_len + fn_len); + fndata = SSDATA (eln_fname); + memcpy (fndata, emacs_execdir, execdir_len); + memcpy (fndata + execdir_len, SSDATA (cu_file), fn_len); } - comp_u->file = - concat2 (Vinvocation_directory, - installation_state == INSTALLED - ? XCAR (comp_u->file) : XCDR (comp_u->file)); - comp_u->handle = dynlib_open (SSDATA (ENCODE_FILE (comp_u->file))); + comp_u->file = eln_fname; + comp_u->handle = dynlib_open (SSDATA (eln_fname)); if (!comp_u->handle) error ("%s", dynlib_error ()); load_comp_unit (comp_u, true, false); @@ -5435,6 +5464,26 @@ dump_do_all_emacs_relocations (const struct dump_header *const header, dump_do_emacs_relocation (dump_base, r[i]); } +#ifdef HAVE_NATIVE_COMP +/* Compute and record the directory of the Emacs executable given the + file name of that executable. */ +static void +pdumper_set_emacs_execdir (char *emacs_executable) +{ + char *p = emacs_executable + strlen (emacs_executable); + + while (p > emacs_executable + && !IS_DIRECTORY_SEP (p[-1])) + --p; + eassert (p > emacs_executable); + emacs_execdir = xpalloc (emacs_execdir, &execdir_size, + p - emacs_executable + 1 - execdir_size, -1, 1); + memcpy (emacs_execdir, emacs_executable, p - emacs_executable); + execdir_len = p - emacs_executable; + emacs_execdir[execdir_len] = '\0'; +} +#endif + enum dump_section { DS_HOT, @@ -5451,7 +5500,7 @@ static Lisp_Object *pdumper_hashes = &zero_vector; N.B. We run very early in initialization, so we can't use lisp, unwinding, xmalloc, and so on. */ int -pdumper_load (const char *dump_filename, char *argv0, char const *original_pwd) +pdumper_load (const char *dump_filename, char *argv0) { intptr_t dump_size; struct stat stat; @@ -5607,9 +5656,11 @@ pdumper_load (const char *dump_filename, char *argv0, char const *original_pwd) for (int i = 0; i < nr_dump_hooks; ++i) dump_hooks[i] (); - /* Once we can allocate and before loading .eln files we must set - Vinvocation_directory (.eln paths are relative to it). */ - init_vars_for_load (argv0, original_pwd); +#ifdef HAVE_NATIVE_COMP + pdumper_set_emacs_execdir (argv0); +#else + (void) argv0; +#endif dump_do_all_dump_reloc_for_phase (header, dump_base, LATE_RELOCS); dump_do_all_dump_reloc_for_phase (header, dump_base, VERY_LATE_RELOCS); diff --git a/src/pdumper.h b/src/pdumper.h index 49e6739b0d..deec9af046 100644 --- a/src/pdumper.h +++ b/src/pdumper.h @@ -140,8 +140,7 @@ enum pdumper_load_result PDUMPER_LOAD_ERROR /* Must be last, as errno may be added. */ }; -int pdumper_load (const char *dump_filename, char *argv0, - char const *original_pwd); +int pdumper_load (const char *dump_filename, char *argv0); struct pdumper_loaded_dump { commit 1789dcdb359bbac371ebabbd07643eaaea67c4f7 Author: Eli Zaretskii Date: Sat Apr 17 11:24:04 2021 +0300 Improve documentation of 'map-y-or-n-p' * lisp/emacs-lisp/map-ynp.el (map-y-or-n-p): Doc fix. (Bug#47833) * doc/lispref/minibuf.texi (Multiple Queries): Fix the wording in the description of 'map-y-or-n-p'. diff --git a/doc/lispref/minibuf.texi b/doc/lispref/minibuf.texi index 726b786905..f16212abdc 100644 --- a/doc/lispref/minibuf.texi +++ b/doc/lispref/minibuf.texi @@ -2128,9 +2128,10 @@ This function asks the user a series of questions, reading a single-character answer in the echo area for each one. The value of @var{list} specifies the objects to ask questions about. -It should be either a list of objects or a generator function. If it is -a function, it should expect no arguments, and should return either the -next object to ask about, or @code{nil}, meaning to stop asking questions. +It should be either a list of objects or a generator function. If it +is a function, it will be called with no arguments, and should return +either the next object to ask about, or @code{nil}, meaning to stop +asking questions. The argument @var{prompter} specifies how to ask each question. If @var{prompter} is a string, the question text is computed like this: @@ -2141,19 +2142,20 @@ The argument @var{prompter} specifies how to ask each question. If @noindent where @var{object} is the next object to ask about (as obtained from -@var{list}). +@var{list}). @xref{Formatting Strings}, for more information about +@code{format}. -If not a string, @var{prompter} should be a function of one argument -(the next object to ask about) and should return the question text. If -the value is a string, that is the question to ask the user. The -function can also return @code{t}, meaning do act on this object (and -don't ask the user), or @code{nil}, meaning ignore this object (and don't -ask the user). +If @var{prompter} is not a string, it should be a function of one +argument (the object to ask about) and should return the question text +for that object. If the value @var{prompter} returns is a string, +that is the question to ask the user. The function can also return +@code{t}, meaning to act on this object without asking the user, or +@code{nil}, which means to silently ignore this object. -The argument @var{actor} says how to act on the answers that the user -gives. It should be a function of one argument, and it is called with -each object that the user says yes for. Its argument is always an -object obtained from @var{list}. +The argument @var{actor} says how to act on the objects for which the +user answers yes. It should be a function of one argument, and will +be called with each object from @var{LIST} for which the user answers +yes. If the argument @var{help} is given, it should be a list of this form: @@ -2163,34 +2165,49 @@ If the argument @var{help} is given, it should be a list of this form: @noindent where @var{singular} is a string containing a singular noun that -describes the objects conceptually being acted on, @var{plural} is the +describes a single object to be acted on, @var{plural} is the corresponding plural noun, and @var{action} is a transitive verb -describing what @var{actor} does. +describing what @var{actor} does with the objects. -If you don't specify @var{help}, the default is @code{("object" -"objects" "act on")}. +If you don't specify @var{help}, it defaults to the list +@w{@code{("object" "objects" "act on")}}. -Each time a question is asked, the user may enter @kbd{y}, @kbd{Y}, or -@key{SPC} to act on that object; @kbd{n}, @kbd{N}, or @key{DEL} to skip -that object; @kbd{!} to act on all following objects; @key{ESC} or -@kbd{q} to exit (skip all following objects); @kbd{.} (period) to act on -the current object and then exit; or @kbd{C-h} to get help. These are -the same answers that @code{query-replace} accepts. The keymap -@code{query-replace-map} defines their meaning for @code{map-y-or-n-p} -as well as for @code{query-replace}; see @ref{Search and Replace}. +Each time a question is asked, the user can answer as follows: + +@table @asis +@item @kbd{y}, @kbd{Y}, or @kbd{@key{SPC}} +act on the object +@item @kbd{n}, @kbd{N}, or @kbd{@key{DEL}} +skip the object +@item @kbd{!} +act on all the following objects +@item @kbd{@key{ESC}} or @kbd{q} +exit (skip all following objects) +@item @kbd{.} (period) +act on the object and then exit +@item @kbd{C-h} +get help +@end table + +@noindent +These are the same answers that @code{query-replace} accepts. The +keymap @code{query-replace-map} defines their meaning for +@code{map-y-or-n-p} as well as for @code{query-replace}; see +@ref{Search and Replace}. You can use @var{action-alist} to specify additional possible answers -and what they mean. It is an alist of elements of the form -@code{(@var{char} @var{function} @var{help})}, each of which defines one -additional answer. In this element, @var{char} is a character (the +and what they mean. If provided, @var{action-alist} should be an +alist whose elements are of the form @w{@code{(@var{char} +@var{function} @var{help})}}. Each of the alist elements defines one +additional answer. In each element, @var{char} is a character (the answer); @var{function} is a function of one argument (an object from -@var{list}); @var{help} is a string. - -When the user responds with @var{char}, @code{map-y-or-n-p} calls -@var{function}. If it returns non-@code{nil}, the object is considered -acted upon, and @code{map-y-or-n-p} advances to the next object in -@var{list}. If it returns @code{nil}, the prompt is repeated for the -same object. +@var{list}); and @var{help} is a string. When the user responds with +@var{char}, @code{map-y-or-n-p} calls @var{function}. If it returns +non-@code{nil}, the object is considered to have been acted upon, and +@code{map-y-or-n-p} advances to the next object in @var{list}. If it +returns @code{nil}, the prompt is repeated for the same object. If +the user requests help, the text in @var{help} is used to describe +these additional answers. Normally, @code{map-y-or-n-p} binds @code{cursor-in-echo-area} while prompting. But if @var{no-cursor-in-echo-area} is non-@code{nil}, it diff --git a/lisp/emacs-lisp/map-ynp.el b/lisp/emacs-lisp/map-ynp.el index 14112a1c14..8d3a42b09f 100644 --- a/lisp/emacs-lisp/map-ynp.el +++ b/lisp/emacs-lisp/map-ynp.el @@ -38,46 +38,62 @@ (defun map-y-or-n-p (prompter actor list &optional help action-alist no-cursor-in-echo-area) - "Ask a series of boolean questions. -Takes args PROMPTER ACTOR LIST, and optional args HELP and ACTION-ALIST. + "Ask a boolean question per PROMPTER for each object in LIST, then call ACTOR. LIST is a list of objects, or a function of no arguments to return the next -object or nil. - -If PROMPTER is a string, the prompt is \(format PROMPTER OBJECT). If not -a string, PROMPTER is a function of one arg (an object from LIST), which -returns a string to be used as the prompt for that object. If the return -value is not a string, it may be nil to ignore the object or non-nil to act -on the object without asking the user. - -ACTOR is a function of one arg (an object from LIST), -which gets called with each object that the user answers `yes' for. - -If HELP is given, it is a list (OBJECT OBJECTS ACTION), -where OBJECT is a string giving the singular noun for an elt of LIST; -OBJECTS is the plural noun for elts of LIST, and ACTION is a transitive -verb describing ACTOR. The default is \(\"object\" \"objects\" \"act on\"). - -At the prompts, the user may enter y, Y, or SPC to act on that object; -n, N, or DEL to skip that object; ! to act on all following objects; -ESC or q to exit (skip all following objects); . (period) to act on the -current object and then exit; or \\[help-command] to get help. - -If ACTION-ALIST is given, it is an alist (KEY FUNCTION HELP) of extra keys -that will be accepted. KEY is a character; FUNCTION is a function of one -arg (an object from LIST); HELP is a string. When the user hits KEY, -FUNCTION is called. If it returns non-nil, the object is considered -\"acted upon\", and the next object from LIST is processed. If it returns -nil, the prompt is repeated for the same object. - -Final optional argument NO-CURSOR-IN-ECHO-AREA non-nil says not to set -`cursor-in-echo-area' while prompting. +object; when it returns nil, the list of objects is considered exhausted. + +If PROMPTER is a string, it should be a format string to be used to format +the question as \(format PROMPTER OBJECT). +If PROMPTER is not a string, it should be a function of one argument, an +object from LIST, which returns a string to be used as the question for +that object. If the function's return value is not a string, it may be +nil to ignore the object, or non-nil to act on the object with ACTOR +without asking the user. + +ACTOR is a function of one argument, an object from LIST, +which gets called with each object for which the user answers `yes' +to the question presented by PROMPTER. + +The user's answers to the questions may be one of the following: + + - y, Y, or SPC to act on that object; + - n, N, or DEL to skip that object; + - ! to act on all following objects; + - ESC or q to exit (skip all following objects); + - . (period) to act on the current object and then exit; or + - \\[help-command] to get help. + +HELP provides information for displaying help when the user +types \\[help-command]. If HELP is given, it should be a list of +the form (OBJECT OBJECTS ACTION), where OBJECT is a string giving +the singular noun describing an element of LIST; OBJECTS is the +plural noun describing several elements of LIST, and ACTION is a +transitive verb describing action by ACTOR on one or more elements +of LIST. If HELP is omitted or nil, it defaults +to \(\"object\" \"objects\" \"act on\"). + +If ACTION-ALIST is given, it is an alist specifying additional keys +that will be accepted as an answer to the questions. Each element +of the alist has the form (KEY FUNCTION HELP), where KEY is a character; +FUNCTION is a function of one argument (an object from LIST); and HELP +is a string. When the user presses KEY, FUNCTION is called; if it +returns non-nil, the object is considered to have been \"acted upon\", +and `map-y-or-n-p' proceeeds to the next object from LIST. If +FUNCTION returns nil, the prompt is re-issued for the same object: this +comes in handy if FUNCTION produces some display that will allow the +user to make an intelligent decision whether the object in question +should be acted upon. If the user types \\[help-command], the string +given by HELP is used to describe the effect of KEY. + +Optional argument NO-CURSOR-IN-ECHO-AREA, if non-nil, means not to set +`cursor-in-echo-area' while prompting with the questions. This function uses `query-replace-map' to define the standard responses, -but not all of the responses which `query-replace' understands -are meaningful here. +but only some of the responses which `query-replace' understands +are meaningful here, as described above. -Returns the number of actions taken." +The function's value is the number of actions taken." (let* ((actions 0) (msg (current-message)) user-keys mouse-event map prompt char elt def commit f9c1008ced59f003d48dd7be39e9ec4aa0f02484 Author: Ashish SHUKLA Date: Fri Apr 16 11:13:09 2021 +0200 * lisp/emacs-lisp/comp.el (comp-effective-async-max-jobs): Handle BSD. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index b5c9cb5826..0122008fc9 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -3860,6 +3860,9 @@ processes from `comp-async-compilations'" ((executable-find "nproc") (string-to-number (shell-command-to-string "nproc"))) + ((eq 'berkeley-unix system-type) + (string-to-number + (shell-command-to-string "sysctl -n hw.ncpu"))) (t 1)) 2)))) comp-async-jobs-number)) commit 686259e65aa7121683c0c65e45ce48adb08ddb58 Author: Andrea Corallo Date: Wed Apr 14 23:58:23 2021 +0200 * configure.ac: Revert prev commit and fix native-comp NetBSD build. diff --git a/configure.ac b/configure.ac index 0e91a49488..3298032311 100644 --- a/configure.ac +++ b/configure.ac @@ -3826,7 +3826,7 @@ if test "${with_native_compilation}" != "no"; then # mingw32 loads the library dynamically. mingw32) ;; # OpenBSD doesn't have libdl, all the functions are in libc - freebsd|openbsd) + netbsd|openbsd) LIBGCCJIT_LIB="-lgccjit" ;; *) LIBGCCJIT_LIB="-lgccjit -ldl" ;; commit bfaa6df492c85d7de007cf69316cbdeea653d703 Author: Andrea Corallo Date: Wed Apr 14 20:00:04 2021 +0200 * configure.ac: Fix native-comp FreeBSD build. diff --git a/configure.ac b/configure.ac index a47871fbd8..0e91a49488 100644 --- a/configure.ac +++ b/configure.ac @@ -3826,7 +3826,7 @@ if test "${with_native_compilation}" != "no"; then # mingw32 loads the library dynamically. mingw32) ;; # OpenBSD doesn't have libdl, all the functions are in libc - openbsd) + freebsd|openbsd) LIBGCCJIT_LIB="-lgccjit" ;; *) LIBGCCJIT_LIB="-lgccjit -ldl" ;; commit 95dd6bb08038e31515568943dcfae13afac8ff70 Author: Eli Zaretskii Date: Wed Apr 14 17:28:19 2021 +0300 Fix MS-Windows build following last change * src/emacs.c (real_filename) [WINDOWSNT]: Fix off-by-one error when allocating storage for a file name. diff --git a/src/emacs.c b/src/emacs.c index f0d75f5c20..a2565645c6 100644 --- a/src/emacs.c +++ b/src/emacs.c @@ -450,16 +450,14 @@ real_filename (char *filename) #ifdef WINDOWSNT /* w32_my_exename resolves symlinks internally, so no need to call realpath. */ - real_name = xmalloc (strlen (filename)); - strcpy (real_name, filename); - return real_name; + real_name = xstrdup (filename); #else real_name = realpath (filename, NULL); if (!real_name) fatal ("could not resolve realpath of \"%s\": %s", filename, strerror (errno)); - return real_name; #endif + return real_name; } /* Set `invocation-name' `invocation-directory'. */ commit 0c1fc9d581ad64efc96c1efccbb4d057796ef807 Author: Andrea Corallo Date: Wed Apr 14 15:04:19 2021 +0200 * Fix native-comp startup for symliked binary (bug#44128) * src/emacs.c (real_filename): New function. (set_invocation_vars, load_pdump): Make use of. diff --git a/src/emacs.c b/src/emacs.c index e5940ce1de..f0d75f5c20 100644 --- a/src/emacs.c +++ b/src/emacs.c @@ -440,6 +440,28 @@ terminate_due_to_signal (int sig, int backtrace_limit) exit (1); } +/* Return the real filename following symlinks in case. + The caller should deallocate the returned buffer. */ + +static char * +real_filename (char *filename) +{ + char *real_name; +#ifdef WINDOWSNT + /* w32_my_exename resolves symlinks internally, so no need to + call realpath. */ + real_name = xmalloc (strlen (filename)); + strcpy (real_name, filename); + return real_name; +#else + real_name = realpath (filename, NULL); + if (!real_name) + fatal ("could not resolve realpath of \"%s\": %s", + filename, strerror (errno)); + return real_name; +#endif +} + /* Set `invocation-name' `invocation-directory'. */ static void @@ -475,6 +497,10 @@ set_invocation_vars (char *argv0, char const *original_pwd) if (! NILP (handler)) raw_name = concat2 (slash_colon, raw_name); + char *filename = real_filename (SSDATA (raw_name)); + raw_name = build_unibyte_string (filename); + xfree (filename); + Vinvocation_name = Ffile_name_nondirectory (raw_name); Vinvocation_directory = Ffile_name_directory (raw_name); @@ -888,17 +914,9 @@ load_pdump (int argc, char **argv, char const *original_pwd) the dump in the hardcoded location. */ if (dump_file && *dump_file) { -#ifdef WINDOWSNT - /* w32_my_exename resolves symlinks internally, so no need to - call realpath. */ -#else - char *real_exename = realpath (dump_file, NULL); - if (!real_exename) - fatal ("could not resolve realpath of \"%s\": %s", - dump_file, strerror (errno)); + char *real_exename = real_filename (dump_file); xfree (dump_file); dump_file = real_exename; -#endif ptrdiff_t exenamelen = strlen (dump_file); #ifndef WINDOWSNT bufsize = exenamelen + 1; commit b064ddd3f600ed28e62b09d556ecced5f80d9883 Merge: 2d23f19e7d 6de79542e4 Author: Andrea Corallo Date: Tue Apr 13 12:06:23 2021 +0200 Merge remote-tracking branch 'savannah/master' into native-comp commit 2d23f19e7d5ff8a1ec1a188dcd530c185029d1f8 Author: Andrea Corallo Date: Tue Apr 13 10:38:14 2021 +0200 * Fix two comp-cstr tests * test/lisp/emacs-lisp/comp-cstr-tests.el (comp-cstr-typespec-tests-alist): Fix test 53 70. diff --git a/test/lisp/emacs-lisp/comp-cstr-tests.el b/test/lisp/emacs-lisp/comp-cstr-tests.el index f2d9bf583e..c2492b93f6 100644 --- a/test/lisp/emacs-lisp/comp-cstr-tests.el +++ b/test/lisp/emacs-lisp/comp-cstr-tests.el @@ -147,7 +147,7 @@ ;; 52 Conservative. ((or (member foo) (not string)) . (not string)) ;; 53 - ((or (not (integer 1 2)) integer) . integer) + ((or (not (integer 1 2)) integer) . t) ;; 54 ((or (not (integer 1 2)) (not integer)) . (not integer)) ;; 55 @@ -181,7 +181,7 @@ ;; 69 ((and (integer 0 20) (not (integer 5 10))) . (or (integer 0 4) (integer 11 20))) ;; 70 - ((and (not (member a)) (not (member b))) . (not (member b a))) + ((and (not (member a)) (not (member b))) . (not (member a b))) ;; 71 ((and (not boolean) (not (member b))) . (not (or (member b) boolean))) ;; 72 commit 70adc28e9798abede5dd8c137c1543b46af6eacc Author: Andrea Corallo Date: Tue Apr 13 10:38:00 2021 +0200 * lisp/emacs-lisp/comp-cstr.el (comp-cstr-union-1-no-mem): (not null) => t. diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el index b2d34af66b..5b189e70be 100644 --- a/lisp/emacs-lisp/comp-cstr.el +++ b/lisp/emacs-lisp/comp-cstr.el @@ -631,7 +631,15 @@ DST is returned." (setf (typeset dst) (typeset neg) (valset dst) (valset neg) (range dst) (range neg) - (neg dst) (neg neg)))))) + (neg dst) (neg neg))))) + + ;; (not null) => t + (when (and (neg dst) + (null (typeset dst)) + (null (valset dst)) + (null (range dst))) + (give-up))) + dst))) (defun comp-cstr-union-1 (range dst &rest srcs) commit 3062480309b0d3bd66370265ed1a1dc79b6edeed Author: Andrea Corallo Date: Mon Apr 12 16:42:01 2021 +0200 * lisp/emacs-lisp/comp-cstr.el (comp-normalize-valset): Remove duplicates. diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el index 7f5d34b45c..b2d34af66b 100644 --- a/lisp/emacs-lisp/comp-cstr.el +++ b/lisp/emacs-lisp/comp-cstr.el @@ -186,12 +186,14 @@ Return them as multiple value." ;;; Value handling. (defun comp-normalize-valset (valset) - "Sort VALSET and return it." - (cl-sort valset (lambda (x y) - ;; We might want to use `sxhash-eql' for speed but - ;; this is safer to keep tests stable. - (< (sxhash-equal x) - (sxhash-equal y))))) + "Sort and remove duplicates from VALSET then return it." + (cl-remove-duplicates + (cl-sort valset (lambda (x y) + ;; We might want to use `sxhash-eql' for speed but + ;; this is safer to keep tests stable. + (< (sxhash-equal x) + (sxhash-equal y)))) + :test #'eq)) (defun comp-union-valsets (&rest valsets) "Union values present into VALSETS." commit 8ed46b7646de7166aa8bbd3b5d29a4947316c900 Author: Alan Third Date: Wed Apr 7 19:02:56 2021 +0100 Remove hardcoded gcc version * configure.ac: Use 'find' to find the brew installed libgccjit libs instead of a hardcoded path. diff --git a/configure.ac b/configure.ac index 698e8affb5..3892eaed64 100644 --- a/configure.ac +++ b/configure.ac @@ -3806,8 +3806,10 @@ if test "${with_native_compilation}" != "no"; then if test -n "$BREW"; then BREW_LIBGCCJIT_PREFIX=`$BREW --prefix --installed libgccjit 2>/dev/null` if test "$BREW_LIBGCCJIT_PREFIX"; then + brew_libdir=`find ${BREW_LIBGCCJIT_PREFIX}/ -name \*.so \ + | sed -e '1!d;s|/[[^/]]*\.so$||'` CFLAGS="$CFLAGS -I${BREW_LIBGCCJIT_PREFIX}/include" - LDFLAGS="$LDFLAGS -L${BREW_LIBGCCJIT_PREFIX}/lib/gcc/10 -I${BREW_LIBGCCJIT_PREFIX}/include" + LDFLAGS="$LDFLAGS -L${brew_libdir} -I${BREW_LIBGCCJIT_PREFIX}/include" fi fi commit a9b9ada6bf5e07da75ddeba6fd985e28987b767b Author: Eli Zaretskii Date: Wed Apr 7 19:43:59 2021 +0300 Fix crash on MS-Windows caused by recent changes * src/pdumper.c (dump_do_dump_relocation): Don't use expand-file-name, as this crashes on MS-Windows. Use file_access_p instead of emacs_fopen. diff --git a/src/pdumper.c b/src/pdumper.c index 9b750a33f3..dc893c59bf 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -5276,12 +5276,13 @@ dump_do_dump_relocation (const uintptr_t dump_base, /* Check just once if this is a local build or Emacs was installed. */ if (installation_state == UNKNOWN) { + /* Can't use expand-file-name here, because we are too + early in the startup, and we will crash at least on + WINDOWSNT. */ Lisp_Object fname = - Fexpand_file_name (XCAR (comp_u->file), Vinvocation_directory); - FILE *file; - if ((file = emacs_fopen (SSDATA (ENCODE_FILE (fname)), "r"))) + concat2 (Vinvocation_directory, XCAR (comp_u->file)); + if (file_access_p (SSDATA (ENCODE_FILE (fname)), F_OK)) { - fclose (file); installation_state = INSTALLED; fixup_eln_load_path (XCAR (comp_u->file)); } @@ -5293,10 +5294,10 @@ dump_do_dump_relocation (const uintptr_t dump_base, } comp_u->file = - Fexpand_file_name (installation_state == INSTALLED - ? XCAR (comp_u->file) : XCDR (comp_u->file), - Vinvocation_directory); - comp_u->handle = dynlib_open (SSDATA (comp_u->file)); + concat2 (Vinvocation_directory, + installation_state == INSTALLED + ? XCAR (comp_u->file) : XCDR (comp_u->file)); + comp_u->handle = dynlib_open (SSDATA (ENCODE_FILE (comp_u->file))); if (!comp_u->handle) error ("%s", dynlib_error ()); load_comp_unit (comp_u, true, false); commit 1f8d75160a27396da363384018a362e04aaea0bd Author: Andrea Corallo Date: Wed Apr 7 15:25:57 2021 +0200 * Improve some docstring in comp.el * lisp/emacs-lisp/comp.el (comp--native-compile) (batch-native-compile, batch-byte-native-compile-for-bootstrap): Improve docstring. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index dfb945bb58..b5c9cb5826 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -3962,9 +3962,11 @@ display a message." (defun comp--native-compile (function-or-file &optional with-late-load output) "Compile FUNCTION-OR-FILE into native code. -This serves as internal implementation of `native-compile'. When WITH-LATE-LOAD is non-nil, mark the compilation unit for late -load once it finishes compiling." +load once it finishes compiling. +This serves as internal implementation of `native-compile' but +allowing for WITH-LATE-LOAD to be controlled is in use also for +the deferred compilation mechanism." (comp-ensure-native-compiler) (unless (or (functionp function-or-file) (stringp function-or-file)) @@ -4142,8 +4144,10 @@ form, return the compiled function." ;;;###autoload (defun batch-native-compile () - "Run `native-compile' on remaining command-line arguments. -Ultra cheap impersonation of `batch-byte-compile'." + "Perform native compilation on remaining command-line arguments. +Use this from the command line, with ‘-batch’; +it won’t work in an interactive Emacs. +Native compilation equivalent to `batch-byte-compile'." (comp-ensure-native-compiler) (cl-loop for file in command-line-args-left if (or (null byte-native-for-bootstrap) @@ -4156,8 +4160,11 @@ Ultra cheap impersonation of `batch-byte-compile'." ;;;###autoload (defun batch-byte-native-compile-for-bootstrap () "Like `batch-native-compile', but used for booststrap. -Generate *.elc files in addition to the *.eln files. If the -environment variable 'NATIVE_DISABLED' is set, only byte compile." +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 `comp-eln-load-path'). +If the environment variable 'NATIVE_DISABLED' is set, only byte +compile." (comp-ensure-native-compiler) (if (equal (getenv "NATIVE_DISABLED") "1") (batch-byte-compile) commit db2a226fc4ec6cfb28663774aee66793eb6f6224 Author: Andrea Corallo Date: Wed Apr 7 14:09:44 2021 +0200 Move gitlab-ci native-comp tests into '/test/infra/gitlab-ci.yml' * .gitlab-ci.yml: Fix incorrect b8d3ae78c5 merge. * test/infra/gitlab-ci.yml (test-native-bootstrap-speed0) (test-native-bootstrap-speed1, test-native-bootstrap-speed2): Move from .gitlab-ci.yml. diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index cf2cf3e359..3138f4184e 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -24,175 +24,5 @@ # Maintainer: Ted Zlatanov # URL: https://emba.gnu.org/emacs/emacs -# Never run merge request pipelines, they usually duplicate push pipelines -# see https://docs.gitlab.com/ee/ci/yaml/README.html#common-if-clauses-for-rules -workflow: - rules: - - if: '$CI_PIPELINE_SOURCE == "merge_request_event"' - when: never - - when: always - -variables: - GIT_STRATEGY: fetch - EMACS_EMBA_CI: 1 - -default: - image: docker:19.03.12 - timeout: 3 hours - before_script: - - docker info - -.job-template: - # these will be cached across builds - cache: - key: ${CI_COMMIT_REF_SLUG} - paths: [] - policy: pull-push - # these will be saved for followup builds - artifacts: - expire_in: 24 hrs - paths: [] - # - "test/**/*.log" - # - "**/*.log" - -.test-template: - rules: - - changes: - - "**/Makefile.in" - - .gitlab-ci.yml - - aclocal.m4 - - autogen.sh - - configure.ac - - lib/*.{h,c} - - lisp/**/*.el - - src/*.{h,c} - - test/infra/* - - test/lisp/**/*.el - - test/src/*.el - - changes: - # gfilemonitor, kqueue - - src/gfilenotify.c - - src/kqueue.c - # MS Windows - - "**/w32*" - # GNUstep - - lisp/term/ns-win.el - - src/ns*.{h,m} - - src/macfont.{h,m} - when: never - - # using the variables for each job - script: - - docker build --target ${target} -t ${target}:${CI_COMMIT_REF_SLUG} -t ${target}:${CI_COMMIT_SHA} -f test/infra/Dockerfile.emba . - # TODO: with make -j4 several of the tests were failing, for example shadowfile-tests, but passed without it - - docker run -i --rm -e EMACS_EMBA_CI=${EMACS_EMBA_CI} ${target}:${CI_COMMIT_SHA} make ${make_params} - -stages: - - fast - - normal - - slow - -test-fast: - stage: fast - extends: [.job-template, .test-template] - variables: - target: emacs-inotify - make_params: "-C test check" - -test-lisp: - stage: normal - extends: [.job-template, .test-template] - variables: - target: emacs-inotify - make_params: "-C test check-lisp" - -test-net: - stage: normal - extends: [.job-template, .test-template] - variables: - target: emacs-inotify - make_params: "-C test check-net" - -test-filenotify-gio: - # This tests file monitor libraries gfilemonitor and gio. - stage: normal - extends: [.job-template, .test-template] - rules: - - if: '$CI_PIPELINE_SOURCE == "schedule"' - changes: - - "**/Makefile.in" - - .gitlab-ci.yml - - lisp/autorevert.el - - lisp/filenotify.el - - lisp/net/tramp-sh.el - - src/gfilenotify.c - - test/infra/* - - test/lisp/autorevert-tests.el - - test/lisp/filenotify-tests.el - variables: - target: emacs-filenotify-gio - make_params: "-k -C test autorevert-tests filenotify-tests" - -test-native-bootstrap-speed0: - # Test a full native bootstrap - # Run for now only speed 0 to limit memory usage and compilation time. - stage: slow - # Uncomment the following to run it only when sceduled. - # only: - # - schedules - script: - - DEBIAN_FRONTEND=noninteractive apt install --no-install-recommends -y -qq -o=Dpkg::Use-Pty=0 libgccjit-6-dev - - ./autogen.sh autoconf - - ./configure --without-makeinfo --with-nativecomp - - make bootstrap NATIVE_FULL_AOT=1 BYTE_COMPILE_EXTRA_FLAGS='--eval "(setq comp-speed 0)"' -j2 - timeout: 8 hours - -test-native-bootstrap-speed1: - stage: slow - script: - - DEBIAN_FRONTEND=noninteractive apt install --no-install-recommends -y -qq -o=Dpkg::Use-Pty=0 libgccjit-6-dev - - ./autogen.sh autoconf - - ./configure --without-makeinfo --with-nativecomp - - make bootstrap BYTE_COMPILE_EXTRA_FLAGS='--eval "(setq comp-speed 1)"' - timeout: 8 hours - -test-native-bootstrap-speed2: - stage: slow - script: - - DEBIAN_FRONTEND=noninteractive apt install --no-install-recommends -y -qq -o=Dpkg::Use-Pty=0 libgccjit-6-dev - - ./autogen.sh autoconf - - ./configure --without-makeinfo --with-nativecomp - - make bootstrap - timeout: 8 hours - -test-gnustep: - # This tests the GNUstep build process - stage: normal - extends: [.job-template, .test-template] - rules: - - if: '$CI_PIPELINE_SOURCE == "schedule"' - changes: - - "**/Makefile.in" - - .gitlab-ci.yml - - configure.ac - - src/ns*.{h,m} - - src/macfont.{h,m} - - lisp/term/ns-win.el - - nextstep/**/* - - test/infra/* - variables: - target: emacs-gnustep - make_params: install - -test-all: - # This tests also file monitor libraries inotify and inotifywatch. - stage: slow - extends: [.job-template, .test-template] - rules: - # note there's no "changes" section, so this always runs on a schedule - - if: '$CI_PIPELINE_SOURCE == "schedule"' - variables: - target: emacs-inotify - make_params: check-expensive # Just load from test/infra, to keep build automation files there. include: '/test/infra/gitlab-ci.yml' diff --git a/test/infra/gitlab-ci.yml b/test/infra/gitlab-ci.yml index 6355513cc9..b740f43402 100644 --- a/test/infra/gitlab-ci.yml +++ b/test/infra/gitlab-ci.yml @@ -243,6 +243,38 @@ test-filenotify-gio: target: emacs-filenotify-gio make_params: "-k -C test autorevert-tests.log filenotify-tests.log" +test-native-bootstrap-speed0: + # Test a full native bootstrap + # Run for now only speed 0 to limit memory usage and compilation time. + stage: slow + # Uncomment the following to run it only when sceduled. + # only: + # - schedules + script: + - DEBIAN_FRONTEND=noninteractive apt install --no-install-recommends -y -qq -o=Dpkg::Use-Pty=0 libgccjit-6-dev + - ./autogen.sh autoconf + - ./configure --without-makeinfo --with-nativecomp + - make bootstrap NATIVE_FULL_AOT=1 BYTE_COMPILE_EXTRA_FLAGS='--eval "(setq comp-speed 0)"' -j2 + timeout: 8 hours + +test-native-bootstrap-speed1: + stage: slow + script: + - DEBIAN_FRONTEND=noninteractive apt install --no-install-recommends -y -qq -o=Dpkg::Use-Pty=0 libgccjit-6-dev + - ./autogen.sh autoconf + - ./configure --without-makeinfo --with-nativecomp + - make bootstrap BYTE_COMPILE_EXTRA_FLAGS='--eval "(setq comp-speed 1)"' + timeout: 8 hours + +test-native-bootstrap-speed2: + stage: slow + script: + - DEBIAN_FRONTEND=noninteractive apt install --no-install-recommends -y -qq -o=Dpkg::Use-Pty=0 libgccjit-6-dev + - ./autogen.sh autoconf + - ./configure --without-makeinfo --with-nativecomp + - make bootstrap + timeout: 8 hours + test-gnustep: # This tests the GNUstep build process stage: platforms commit c35a515a2f7045f004299f601f6d1927ea16cd47 Author: Alan Third Date: Fri Apr 2 18:06:59 2021 +0100 Fix install with NS app bundle * configure.ac: Set up CFLAGS and LDFLAGS to find a Homebrew installation of libgccjit. * Makefile.in (ELN_DESTDIR): Set to the app bundle resource dir when required. (install-eln): macOS install doesn't support the -D flag, so make the directories separately. diff --git a/Makefile.in b/Makefile.in index e318db746d..efe89b9b93 100644 --- a/Makefile.in +++ b/Makefile.in @@ -323,10 +323,11 @@ COPYDESTS = "$(DESTDIR)${etcdir}" "$(DESTDIR)${lispdir}" ifeq (${ns_self_contained},no) BIN_DESTDIR='$(DESTDIR)${bindir}/' +ELN_DESTDIR = $(DESTDIR)${libdir}/emacs/${version}/ else BIN_DESTDIR='${ns_appbindir}/' +ELN_DESTDIR = ${ns_appresdir}/ endif -ELN_DESTDIR = $(DESTDIR)${libdir}/emacs/${version}/ all: ${SUBDIR} info @@ -752,7 +753,8 @@ install-etc: ### Install native compiled Lisp files. install-eln: ifeq ($(HAVE_NATIVE_COMP),yes) - find native-lisp -type f -exec ${INSTALL_DATA} -D "{}" "$(ELN_DESTDIR){}" \; + find native-lisp -type d -exec $(MKDIR_P) "$(ELN_DESTDIR){}" \; ; \ + find native-lisp -type f -exec ${INSTALL_DATA} "{}" "$(ELN_DESTDIR){}" \; endif ### Build Emacs and install it, stripping binaries while installing them. diff --git a/configure.ac b/configure.ac index 4284c99714..698e8affb5 100644 --- a/configure.ac +++ b/configure.ac @@ -3801,6 +3801,16 @@ if test "${with_native_compilation}" != "no"; then if test "${HAVE_ZLIB}" = no; then AC_MSG_ERROR(['--with-nativecomp' requires zlib]) fi + + # Ensure libgccjit installed by Homebrew can be found. + if test -n "$BREW"; then + BREW_LIBGCCJIT_PREFIX=`$BREW --prefix --installed libgccjit 2>/dev/null` + if test "$BREW_LIBGCCJIT_PREFIX"; then + CFLAGS="$CFLAGS -I${BREW_LIBGCCJIT_PREFIX}/include" + LDFLAGS="$LDFLAGS -L${BREW_LIBGCCJIT_PREFIX}/lib/gcc/10 -I${BREW_LIBGCCJIT_PREFIX}/include" + fi + fi + # Check if libgccjit is available. AC_CHECK_LIB(gccjit, gcc_jit_context_acquire, [], [libgccjit_not_found]) AC_CHECK_HEADERS(libgccjit.h, [], [libgccjit_dev_not_found]) commit ce15b23846cd82acccb6ce5dd13b0a42f487296b Author: Andrea Corallo Date: Wed Apr 7 09:50:02 2021 +0200 * Makefile.in (BIN_DESTDIR, src): Fix 'BIN_DESTDIR' on MacOS. diff --git a/Makefile.in b/Makefile.in index aa32ec8bc5..e318db746d 100644 --- a/Makefile.in +++ b/Makefile.in @@ -321,6 +321,11 @@ CONFIG_STATUS_FILES_IN = \ COPYDIR = ${srcdir}/etc ${srcdir}/lisp COPYDESTS = "$(DESTDIR)${etcdir}" "$(DESTDIR)${lispdir}" +ifeq (${ns_self_contained},no) +BIN_DESTDIR='$(DESTDIR)${bindir}/' +else +BIN_DESTDIR='${ns_appbindir}/' +endif ELN_DESTDIR = $(DESTDIR)${libdir}/emacs/${version}/ all: ${SUBDIR} info @@ -416,7 +421,7 @@ lib lib-src lisp nt: Makefile dirstate = .git/logs/HEAD VCSWITNESS = $(if $(wildcard $(srcdir)/$(dirstate)),$$(srcdir)/../$(dirstate)) src: Makefile - $(MAKE) -C $@ VCSWITNESS='$(VCSWITNESS)' BIN_DESTDIR='$(DESTDIR)${bindir}/' \ + $(MAKE) -C $@ VCSWITNESS='$(VCSWITNESS)' BIN_DESTDIR='$(BIN_DESTDIR)' \ ELN_DESTDIR='$(ELN_DESTDIR)' all blessmail: Makefile src commit 208ffc284c7f492151c1d2f76845cefea7a35341 Author: Andrea Corallo Date: Tue Apr 6 21:40:15 2021 +0200 * .gitlab-ci.yml: Move native-comp tests into 'slow' stage. diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index acc1649bda..cf2cf3e359 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -136,7 +136,7 @@ test-filenotify-gio: test-native-bootstrap-speed0: # Test a full native bootstrap # Run for now only speed 0 to limit memory usage and compilation time. - stage: test + stage: slow # Uncomment the following to run it only when sceduled. # only: # - schedules @@ -148,7 +148,7 @@ test-native-bootstrap-speed0: timeout: 8 hours test-native-bootstrap-speed1: - stage: test + stage: slow script: - DEBIAN_FRONTEND=noninteractive apt install --no-install-recommends -y -qq -o=Dpkg::Use-Pty=0 libgccjit-6-dev - ./autogen.sh autoconf @@ -157,7 +157,7 @@ test-native-bootstrap-speed1: timeout: 8 hours test-native-bootstrap-speed2: - stage: test + stage: slow script: - DEBIAN_FRONTEND=noninteractive apt install --no-install-recommends -y -qq -o=Dpkg::Use-Pty=0 libgccjit-6-dev - ./autogen.sh autoconf commit 65681982134d973ee6bc78b627866e2ca4e242e7 Author: Andrea Corallo Date: Tue Apr 6 21:13:47 2021 +0200 * src/pdumper.c (dump_do_dump_relocation): Use `expand-file-name'. diff --git a/src/pdumper.c b/src/pdumper.c index e266b35ca6..9b750a33f3 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -5277,7 +5277,7 @@ dump_do_dump_relocation (const uintptr_t dump_base, if (installation_state == UNKNOWN) { Lisp_Object fname = - concat2 (Vinvocation_directory, XCAR (comp_u->file)); + Fexpand_file_name (XCAR (comp_u->file), Vinvocation_directory); FILE *file; if ((file = emacs_fopen (SSDATA (ENCODE_FILE (fname)), "r"))) { @@ -5293,9 +5293,9 @@ dump_do_dump_relocation (const uintptr_t dump_base, } comp_u->file = - concat2 (Vinvocation_directory, - installation_state == INSTALLED - ? XCAR (comp_u->file) : XCDR (comp_u->file)); + Fexpand_file_name (installation_state == INSTALLED + ? XCAR (comp_u->file) : XCDR (comp_u->file), + Vinvocation_directory); comp_u->handle = dynlib_open (SSDATA (comp_u->file)); if (!comp_u->handle) error ("%s", dynlib_error ()); commit b77575198c4395b9345ad6694d7fb1fe23aeace6 Author: Andrea Corallo Date: Tue Apr 6 21:02:58 2021 +0200 ; * lisp/loadup.el: Fix comment. diff --git a/lisp/loadup.el b/lisp/loadup.el index c3948e465f..650288f9f8 100644 --- a/lisp/loadup.el +++ b/lisp/loadup.el @@ -452,7 +452,7 @@ lost after dumping"))) (when (featurep 'nativecomp) ;; Fix the compilation unit filename to have it working when ;; installed or if the source directory got moved. This is set to be - ;; a cons cell of the form: + ;; a pair in the form of: ;; (rel-filename-from-install-bin . rel-filename-from-local-bin). (let ((h (make-hash-table :test #'eq)) (bin-dest-dir (cadr (member "--bin-dest" command-line-args))) commit 02724cc2fc606c583faf33ae58ea7c67bfc1485f Author: Andrea Corallo Date: Tue Apr 6 18:27:04 2021 +0200 ; * admin/MAINTAINERS: Tabify last change. diff --git a/admin/MAINTAINERS b/admin/MAINTAINERS index 5dc88719ed..02b8cf39bd 100644 --- a/admin/MAINTAINERS +++ b/admin/MAINTAINERS @@ -132,8 +132,8 @@ Amin Bandali doc/misc/erc.texi Andrea Corallo - Lisp native compiler - src/comp.c + Lisp native compiler + src/comp.c lisp/emacs-lisp/comp.el lisp/emacs-lisp/comp-cstr.el test/src/comp-*.el commit 320f5390567016b5287d15416853e5421e9c2f3a Author: Andrea Corallo Date: Tue Apr 6 17:01:25 2021 +0200 ; * etc/TODO (pdump): Add a note about native compiler and re-dumping. diff --git a/etc/TODO b/etc/TODO index 9448617626..f806b6ca4f 100644 --- a/etc/TODO +++ b/etc/TODO @@ -500,6 +500,13 @@ access in cases which need more than Lisp. ** Fix portable dumping so that you can redump without using -batch +*** Redumps and native compiler "preloaded" sub-folder. +In order to depose new .eln files being compiled into the "preloaded" +sub-folder the native compiler needs to know in advance if this file +will be preloaded or not. As .eln files are not moved afterwards +subsequent redumps might refer to .eln file out of the "preloaded" +sub-folder. + ** Imenu could be extended into a file-structure browsing mechanism This could use code like that of customize-groups. commit 7bf141e944583929a77baf859cc711ba7c80f91e Author: Andrea Corallo Date: Tue Apr 6 16:19:58 2021 +0200 ; * Add myself to MAINTAINERS file diff --git a/admin/MAINTAINERS b/admin/MAINTAINERS index 53afe87a0f..5dc88719ed 100644 --- a/admin/MAINTAINERS +++ b/admin/MAINTAINERS @@ -131,6 +131,13 @@ Amin Bandali lisp/erc/* doc/misc/erc.texi +Andrea Corallo + Lisp native compiler + src/comp.c + lisp/emacs-lisp/comp.el + lisp/emacs-lisp/comp-cstr.el + test/src/comp-*.el + ============================================================================== 2. Areas that someone is willing to maintain, although he would not necessarily mind if someone else was the official maintainer. commit 74b58f28ecbc6fe9d7a60c96c79acfdf2329ff73 Merge: 0a3e715e1f 14d295871a Author: Andrea Corallo Date: Mon Apr 5 21:00:18 2021 +0200 Merge remote-tracking branch 'savannah/master' into native-comp commit 0a3e715e1f5e13874139b4678375b8f5704b800b Author: Andrea Corallo Date: Mon Apr 5 20:56:28 2021 +0200 * Introduce `comp-file-preloaded-p' * src/comp.c (syms_of_comp): Define `comp-file-preloaded-p'. (Fcomp_el_to_eln_filename): Account for `comp-file-preloaded-p'. diff --git a/src/comp.c b/src/comp.c index 6817fe2f92..c4b9b4b6c1 100644 --- a/src/comp.c +++ b/src/comp.c @@ -4131,16 +4131,18 @@ directory in `comp-eln-load-path' otherwise. */) if (!file_name_absolute_p (SSDATA (base_dir))) base_dir = Fexpand_file_name (base_dir, Vinvocation_directory); - /* In case the file being compiled is found in 'LISP_PRELOADED' - target for output the 'preloaded' subfolder. */ + /* In case the file being compiled is found in 'LISP_PRELOADED' or + `comp-file-preloaded-p' is non-nil target for output the + 'preloaded' subfolder. */ Lisp_Object lisp_preloaded = Fgetenv_internal (build_string ("LISP_PRELOADED"), Qnil); base_dir = Fexpand_file_name (Vcomp_native_version_dir, base_dir); - if (!NILP (lisp_preloaded) - && !NILP (Fmember (CALL1I (file-name-base, source_filename), - Fmapcar (intern_c_string ("file-name-base"), - CALL1I (split-string, lisp_preloaded))))) - base_dir = Fexpand_file_name (build_string ("preloaded"), base_dir); + if (comp_file_preloaded_p + || (!NILP (lisp_preloaded) + && !NILP (Fmember (CALL1I (file-name-base, source_filename), + Fmapcar (intern_c_string ("file-name-base"), + CALL1I (split-string, lisp_preloaded)))))) + base_dir = Fexpand_file_name (build_string ("preloaded"), base_dir); return Fexpand_file_name (filename, base_dir); } @@ -5398,6 +5400,10 @@ the user during load. For internal use. */); V_comp_no_native_file_h = CALLN (Fmake_hash_table, QCtest, Qequal); + DEFVAR_BOOL ("comp-file-preloaded-p", comp_file_preloaded_p, + doc: /* When non-nil assume the file being compiled to +be preloaded. */); + Fprovide (intern_c_string ("nativecomp"), Qnil); #endif /* #ifdef HAVE_NATIVE_COMP */ commit 39bc9bc77066c0c40d2e5fd0769ce3701055a10b Author: Andrea Corallo Date: Sun Apr 4 22:45:36 2021 +0200 * src/comp.c (fixup_eln_load_path): Fix parameter name. diff --git a/src/comp.c b/src/comp.c index c167aaa944..6817fe2f92 100644 --- a/src/comp.c +++ b/src/comp.c @@ -4750,7 +4750,7 @@ maybe_defer_native_compilation (Lisp_Object function_name, /* Fixup the system eln-cache dir. This is the last entry in `comp-eln-load-path'. */ void -fixup_eln_load_path (Lisp_Object directory) +fixup_eln_load_path (Lisp_Object eln_filename) { Lisp_Object last_cell = Qnil; Lisp_Object tmp = Vcomp_eln_load_path; @@ -4760,7 +4760,7 @@ fixup_eln_load_path (Lisp_Object directory) Lisp_Object eln_cache_sys = Ffile_name_directory (concat2 (Vinvocation_directory, - directory)); + eln_filename)); bool preloaded = !NILP (Fequal (Fsubstring (eln_cache_sys, make_fixnum (-10), make_fixnum (-1)), commit 9333bc48638127899dddc7796afd2df80441f494 Author: Andrea Corallo Date: Sun Apr 4 20:54:55 2021 +0200 * src/comp.c (Fcomp_el_to_eln_filename): Fix doc. diff --git a/src/comp.c b/src/comp.c index 9bad9b9667..c167aaa944 100644 --- a/src/comp.c +++ b/src/comp.c @@ -4088,7 +4088,8 @@ DEFUN ("comp-el-to-eln-filename", Fcomp_el_to_eln_filename, Scomp_el_to_eln_filename, 1, 2, 0, doc: /* Return the .eln filename for source FILENAME to used for new compilations. -If BASE-DIR is nil use the first entry in `comp-eln-load-path'. */) +If BASE-DIR is non-nil use it as a base directory, look for a suitable +directory in `comp-eln-load-path' otherwise. */) (Lisp_Object filename, Lisp_Object base_dir) { Lisp_Object source_filename = filename; commit 1ad0ecea2bbdfad9b543315a0ab28abcbfb1272f Author: Andrea Corallo Date: Sun Mar 21 09:15:25 2021 +0100 * lisp/emacs-lisp/comp.el (comp-clean-up-stale-eln): Clean-up all .eln dirs. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 7f41a97f6b..dfb945bb58 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -3785,11 +3785,14 @@ sharing the original source filename (including FILE)." with filename-hash = (match-string 1 file) with regexp = (rx-to-string `(seq "-" ,filename-hash "-" (1+ hex) ".eln" eos)) - for dir in (butlast (comp-eln-load-path-eff)) ; Skip last dir. + for dir in (comp-eln-load-path-eff) do (cl-loop for f in (when (file-exists-p dir) (directory-files dir t regexp t)) - do (comp-delete-or-replace-file f))))) + ;; We may not be able to delete the file if we have no write + ;; permisison. + do (ignore-error file-error + (comp-delete-or-replace-file f)))))) (defun comp-delete-or-replace-file (oldfile &optional newfile) "Replace OLDFILE with NEWFILE. commit 6f8ec1449197f1fcd730df91dddf6f7750284593 Author: Andrea Corallo Date: Sun Apr 4 17:10:08 2021 +0200 Output native compiled preloaded files into the 'preloaded' subfolder * src/comp.c (fixup_eln_load_path): Account the fact that the file can be dumped in the 'preloaded' subfolder. * lisp/loadup.el: Likewise. * src/lread.c (maybe_swap_for_eln1): New function. (maybe_swap_for_eln): Handle 'preloaded' subfolder. * src/Makefile.in (LISP_PRELOADED): Export preloaded files. diff --git a/lisp/loadup.el b/lisp/loadup.el index 57058ac4aa..c3948e465f 100644 --- a/lisp/loadup.el +++ b/lisp/loadup.el @@ -465,17 +465,25 @@ lost after dumping"))) (when (subr-native-elisp-p f) (puthash (subr-native-comp-unit f) nil h))))) (maphash (lambda (cu _) - (native-comp-unit-set-file - cu - (cons - ;; Relative filename from the installed binary. - (file-relative-name (concat eln-dest-dir - (file-name-nondirectory - (native-comp-unit-file cu))) - bin-dest-dir) - ;; Relative filename from the built uninstalled binary. - (file-relative-name (native-comp-unit-file cu) - invocation-directory)))) + (let* ((file (native-comp-unit-file cu)) + (preloaded (equal (substring (file-name-directory file) + -10 -1) + "preloaded")) + (eln-dest-dir-eff (if preloaded + (expand-file-name "preloaded" + eln-dest-dir) + eln-dest-dir))) + (native-comp-unit-set-file + cu + (cons + ;; Relative filename from the installed binary. + (file-relative-name (expand-file-name + (file-name-nondirectory + file) + eln-dest-dir-eff) + bin-dest-dir) + ;; Relative filename from the built uninstalled binary. + (file-relative-name file invocation-directory))))) h)))) (when (hash-table-p purify-flag) diff --git a/src/Makefile.in b/src/Makefile.in index c6b1f55644..b8bad73b00 100644 --- a/src/Makefile.in +++ b/src/Makefile.in @@ -500,6 +500,7 @@ shortlisp := $(filter-out ${shortlisp_filter},${shortlisp}) ## the critical path (relevant in parallel compilations). ## We don't really need to sort, but may as well use it to remove duplicates. shortlisp := loaddefs.el loadup.el $(sort ${shortlisp}) +export LISP_PRELOADED = ${shortlisp} lisp = $(addprefix ${lispsource}/,${shortlisp}) ## Construct full set of libraries to be linked. diff --git a/src/comp.c b/src/comp.c index 67c8e39315..9bad9b9667 100644 --- a/src/comp.c +++ b/src/comp.c @@ -4091,6 +4091,7 @@ for new compilations. If BASE-DIR is nil use the first entry in `comp-eln-load-path'. */) (Lisp_Object filename, Lisp_Object base_dir) { + Lisp_Object source_filename = filename; filename = Fcomp_el_to_eln_rel_filename (filename); /* If base_dir was not specified search inside Vcomp_eln_load_path @@ -4129,9 +4130,18 @@ If BASE-DIR is nil use the first entry in `comp-eln-load-path'. */) if (!file_name_absolute_p (SSDATA (base_dir))) base_dir = Fexpand_file_name (base_dir, Vinvocation_directory); - return Fexpand_file_name (filename, - Fexpand_file_name (Vcomp_native_version_dir, - base_dir)); + /* In case the file being compiled is found in 'LISP_PRELOADED' + target for output the 'preloaded' subfolder. */ + Lisp_Object lisp_preloaded = + Fgetenv_internal (build_string ("LISP_PRELOADED"), Qnil); + base_dir = Fexpand_file_name (Vcomp_native_version_dir, base_dir); + if (!NILP (lisp_preloaded) + && !NILP (Fmember (CALL1I (file-name-base, source_filename), + Fmapcar (intern_c_string ("file-name-base"), + CALL1I (split-string, lisp_preloaded))))) + base_dir = Fexpand_file_name (build_string ("preloaded"), base_dir); + + return Fexpand_file_name (filename, base_dir); } DEFUN ("comp--install-trampoline", Fcomp__install_trampoline, @@ -4750,10 +4760,15 @@ fixup_eln_load_path (Lisp_Object directory) Lisp_Object eln_cache_sys = Ffile_name_directory (concat2 (Vinvocation_directory, directory)); - /* One directory up... */ - eln_cache_sys = - Ffile_name_directory (Fsubstring (eln_cache_sys, Qnil, - make_fixnum (-1))); + bool preloaded = + !NILP (Fequal (Fsubstring (eln_cache_sys, make_fixnum (-10), + make_fixnum (-1)), + build_string ("preloaded"))); + /* One or two directories up... */ + for (int i = 0; i < (preloaded ? 2 : 1); i++) + eln_cache_sys = + Ffile_name_directory (Fsubstring (eln_cache_sys, Qnil, + make_fixnum (-1))); Fsetcar (last_cell, eln_cache_sys); } diff --git a/src/lread.c b/src/lread.c index 156df73de8..e53e1f65ab 100644 --- a/src/lread.c +++ b/src/lread.c @@ -1645,6 +1645,40 @@ directories, make sure the PREDICATE function returns `dir-ok' for them. */) return file; } +#ifdef HAVE_NATIVE_COMP +static bool +maybe_swap_for_eln1 (Lisp_Object src_name, Lisp_Object eln_name, + Lisp_Object *filename, int *fd, struct timespec mtime) +{ + struct stat eln_st; + int eln_fd = emacs_open (SSDATA (ENCODE_FILE (eln_name)), O_RDONLY, 0); + + if (eln_fd > 0) + { + if (fstat (eln_fd, &eln_st) || S_ISDIR (eln_st.st_mode)) + emacs_close (eln_fd); + else + { + struct timespec eln_mtime = get_stat_mtime (&eln_st); + if (timespec_cmp (eln_mtime, mtime) >= 0) + { + emacs_close (*fd); + *fd = eln_fd; + *filename = eln_name; + /* Store the eln -> el relation. */ + Fputhash (Ffile_name_nondirectory (eln_name), + src_name, Vcomp_eln_to_el_h); + return true; + } + else + emacs_close (eln_fd); + } + } + + return false; +} +#endif + /* Look for a suitable .eln file to be loaded in place of FILENAME. If found replace the content of FILENAME and FD. */ @@ -1653,7 +1687,6 @@ maybe_swap_for_eln (bool no_native, Lisp_Object *filename, int *fd, struct timespec mtime) { #ifdef HAVE_NATIVE_COMP - struct stat eln_st; if (no_native || load_no_native) @@ -1687,36 +1720,24 @@ maybe_swap_for_eln (bool no_native, Lisp_Object *filename, int *fd, } Lisp_Object eln_rel_name = Fcomp_el_to_eln_rel_filename (src_name); + Lisp_Object dir = Qnil; FOR_EACH_TAIL_SAFE (eln_path_tail) { + dir = XCAR (eln_path_tail); Lisp_Object eln_name = Fexpand_file_name (eln_rel_name, - Fexpand_file_name (Vcomp_native_version_dir, - XCAR (eln_path_tail))); - int eln_fd = emacs_open (SSDATA (ENCODE_FILE (eln_name)), O_RDONLY, 0); - - if (eln_fd > 0) - { - if (fstat (eln_fd, &eln_st) || S_ISDIR (eln_st.st_mode)) - emacs_close (eln_fd); - else - { - struct timespec eln_mtime = get_stat_mtime (&eln_st); - if (timespec_cmp (eln_mtime, mtime) >= 0) - { - *filename = eln_name; - emacs_close (*fd); - *fd = eln_fd; - /* Store the eln -> el relation. */ - Fputhash (Ffile_name_nondirectory (eln_name), - src_name, Vcomp_eln_to_el_h); - return; - } - else - emacs_close (eln_fd); - } - } + Fexpand_file_name (Vcomp_native_version_dir, dir)); + if (maybe_swap_for_eln1 (src_name, eln_name, filename, fd, mtime)) + return; } + + /* Look also in preloaded subfolder of the last entry in + `comp-eln-load-path'. */ + dir = Fexpand_file_name (build_string ("preloaded"), + Fexpand_file_name (Vcomp_native_version_dir, + dir)); + maybe_swap_for_eln1 (src_name, Fexpand_file_name (eln_rel_name, dir), + filename, fd, mtime); #endif } commit 978afd788fd0496540f715b83f18ed390ca8d5a4 Author: Andrea Corallo Date: Thu Apr 1 22:15:08 2021 +0200 * src/comp.h (unload_comp_unit): Define for vanilla build (warning removal). diff --git a/src/comp.h b/src/comp.h index d01bc17565..e17b843d13 100644 --- a/src/comp.h +++ b/src/comp.h @@ -98,6 +98,10 @@ maybe_defer_native_compilation (Lisp_Object function_name, Lisp_Object definition) {} +static inline +void unload_comp_unit (struct Lisp_Native_Comp_Unit *cu) +{} + extern void syms_of_comp (void); #endif /* #ifdef HAVE_NATIVE_COMP */ commit dc393517ca1cfef7770bffdfe2b7fd3c2c5e7bbf Author: Andrea Corallo Date: Thu Apr 1 14:27:12 2021 +0200 Issue a warning when eln look-up fails due to missing .el source file. * lisp/emacs-lisp/comp.el (comp-warning-on-missing-source): New customize. * src/lread.c (maybe_swap_for_eln): Issue a warning when eln look-up fails due to missing .el source file. * src/comp.c (syms_of_comp): Define 'Qcomp_warning_on_missing_source'. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 213eb7b412..7f41a97f6b 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -180,6 +180,13 @@ the .eln output directory." :type 'boolean :version "28.1") +(defcustom comp-warning-on-missing-source t + "Emit a warning if a byte-code file being loaded has no corresponding source. +The source file is necessary for native code file look-up and deferred +compilation mechanism." + :type 'boolean + :version "28.1") + (defvar no-native-compile nil "Non-nil to prevent native-compiling of Emacs Lisp code. Note that when `no-byte-compile' is set to non-nil it overrides the value of diff --git a/src/comp.c b/src/comp.c index eb734d5833..67c8e39315 100644 --- a/src/comp.c +++ b/src/comp.c @@ -5254,7 +5254,8 @@ compiled one. */); DEFSYM (Qlate, "late"); DEFSYM (Qlambda_fixup, "lambda-fixup"); DEFSYM (Qgccjit, "gccjit"); - DEFSYM (Qcomp_subr_trampoline_install, "comp-subr-trampoline-install") + DEFSYM (Qcomp_subr_trampoline_install, "comp-subr-trampoline-install"); + DEFSYM (Qcomp_warning_on_missing_source, "comp-warning-on-missing-source"); /* To be signaled by the compiler. */ DEFSYM (Qnative_compiler_error, "native-compiler-error"); diff --git a/src/lread.c b/src/lread.c index ec6f09238b..156df73de8 100644 --- a/src/lread.c +++ b/src/lread.c @@ -1674,8 +1674,16 @@ maybe_swap_for_eln (bool no_native, Lisp_Object *filename, int *fd, { src_name = concat2 (src_name, build_string (".gz")); if (NILP (Ffile_exists_p (src_name))) - /* Can't find the corresponding source file. */ - return; + { + if (!NILP (find_symbol_value (Qcomp_warning_on_missing_source))) + call2 (intern_c_string ("display-warning"), + Qcomp, + CALLN (Fformat, + build_string ("Cannot look-up eln file as no source " + "file was found for %s"), + *filename)); + return; + } } Lisp_Object eln_rel_name = Fcomp_el_to_eln_rel_filename (src_name); commit 8d550700c535dbcd4721cc65c0a11decbf070abb Author: Eli Zaretskii Date: Wed Mar 31 22:11:08 2021 +0300 * src/comp.c (Fcomp__compile_ctxt_to_file): Fix debug level 1. diff --git a/src/comp.c b/src/comp.c index a87a8f30c3..eb734d5833 100644 --- a/src/comp.c +++ b/src/comp.c @@ -4493,7 +4493,7 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, add_driver_options (); - if (comp.debug >= 1) + if (comp.debug > 1) gcc_jit_context_dump_to_file (comp.ctxt, format_string ("%s.c", SSDATA (ebase_name)), 1); commit 8e524f459149dfd83e2205d24c174074b10d5c6a Author: Andrea Corallo Date: Wed Mar 31 20:29:32 2021 +0200 * lisp/emacs-lisp/comp.el (comp-final): Clean-up temporary file. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 59e9dbc013..213eb7b412 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -3666,7 +3666,9 @@ Prepare every function for final compilation and drive the C back-end." (call-process (expand-file-name invocation-name invocation-directory) nil t t "--batch" "-l" temp-file)) - output + (progn + (delete-file temp-file) + output) (signal 'native-compiler-error (buffer-string))) (comp-log-to-buffer (buffer-string)))))))) commit 53ca0d98441da75be49111a3a88c1a7629f27d6d Author: Andrea Corallo Date: Wed Mar 31 20:13:46 2021 +0200 Rework native compilation `comp-debug' (bug#46495) * lisp/emacs-lisp/comp.el (comp-debug): Update docstring and move default on Windows systems from 0 to 1. * src/comp.c (Fcomp__compile_ctxt_to_file): Tweak debug levels. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 2f9738a7e2..59e9dbc013 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -56,14 +56,14 @@ :safe #'integerp :version "28.1") -(defcustom comp-debug 0 +(defcustom comp-debug (if (eq 'windows-nt system-type) 1 0) "Debug level for native compilation, a number between 0 and 3. This is intended for debugging the compiler itself. - 0 no debugging output. - This is the recommended value unless you are debugging the compiler itself. - 1 emit debug symbols and dump pseudo C code. - 2 dump gcc passes. - 3 dump libgccjit log file." + 0 no debug output. + 1 emit debug symbols. + 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 :safe #'natnump :version "28.1") diff --git a/src/comp.c b/src/comp.c index b286f6077f..a87a8f30c3 100644 --- a/src/comp.c +++ b/src/comp.c @@ -4431,7 +4431,7 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, gcc_jit_context_set_bool_option (comp.ctxt, GCC_JIT_BOOL_OPTION_DEBUGINFO, 1); - if (comp.debug > 2) + if (comp.debug >= 3) { logfile = emacs_fopen ("libgccjit.log", "w"); gcc_jit_context_set_logfile (comp.ctxt, @@ -4493,7 +4493,7 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, add_driver_options (); - if (comp.debug) + if (comp.debug >= 1) gcc_jit_context_dump_to_file (comp.ctxt, format_string ("%s.c", SSDATA (ebase_name)), 1); commit 613caa9527ef56fb9b810d2b9478cbe9784baca0 Author: Andrea Corallo Date: Wed Mar 31 14:49:36 2021 +0200 Do not defer compilation when bytecode is explicitly requested (bug#46617) * src/comp.c (maybe_defer_native_compilation): Check if the file is registered in 'V_comp_no_native_file_h'. (syms_of_comp): 'V_comp_no_native_file_h' new global. * src/lread.c (maybe_swap_for_eln): Register files in 'V_comp_no_native_file_h'. * lisp/faces.el (tty-run-terminal-initialization): Do not explicitly load .elc file to not exclude .eln being loaded in place. diff --git a/lisp/faces.el b/lisp/faces.el index 42f4cddfb1..68bfbbae38 100644 --- a/lisp/faces.el +++ b/lisp/faces.el @@ -2244,7 +2244,8 @@ If you set `term-file-prefix' to nil, this function does nothing." (let ((file (locate-library (concat term-file-prefix type)))) (and file (or (assoc file load-history) - (load file t t))))) + (load (file-name-sans-extension file) + t t))))) type) ;; Next, try to find a matching initialization function, and call it. (tty-find-type #'(lambda (type) diff --git a/src/comp.c b/src/comp.c index 857f798a8d..b286f6077f 100644 --- a/src/comp.c +++ b/src/comp.c @@ -4689,7 +4689,8 @@ maybe_defer_native_compilation (Lisp_Object function_name, || !NILP (Vpurify_flag) || !COMPILEDP (definition) || !STRINGP (Vload_true_file_name) - || !suffix_p (Vload_true_file_name, ".elc")) + || !suffix_p (Vload_true_file_name, ".elc") + || !NILP (Fgethash (Vload_true_file_name, V_comp_no_native_file_h, Qnil))) return; Lisp_Object src = @@ -5373,6 +5374,13 @@ This is used to prevent double trampoline instantiation but also to protect the trampolines against GC. */); Vcomp_installed_trampolines_h = CALLN (Fmake_hash_table); + DEFVAR_LISP ("comp-no-native-file-h", V_comp_no_native_file_h, + doc: /* Files for which no deferred compilation has to +be performed because the bytecode version was explicitly requested by +the user during load. +For internal use. */); + V_comp_no_native_file_h = CALLN (Fmake_hash_table, QCtest, Qequal); + Fprovide (intern_c_string ("nativecomp"), Qnil); #endif /* #ifdef HAVE_NATIVE_COMP */ diff --git a/src/lread.c b/src/lread.c index e8c257a13c..ec6f09238b 100644 --- a/src/lread.c +++ b/src/lread.c @@ -1655,6 +1655,12 @@ maybe_swap_for_eln (bool no_native, Lisp_Object *filename, int *fd, #ifdef HAVE_NATIVE_COMP struct stat eln_st; + if (no_native + || load_no_native) + Fputhash (*filename, Qt, V_comp_no_native_file_h); + else + Fremhash (*filename, V_comp_no_native_file_h); + if (no_native || load_no_native || !suffix_p (*filename, ".elc")) commit 515378434a44b9979e8c8a6e04203695095bdc40 Merge: aa159bf696 3b1c646202 Author: Andrea Corallo Date: Wed Mar 31 10:48:02 2021 +0200 Merge remote-tracking branch 'savannah/master' into native-comp commit aa159bf6963ef3f741bfbd787507405c02cc4974 Author: Andrea Corallo Date: Wed Mar 31 10:24:55 2021 +0200 * lisp/emacs-lisp/comp.el (comp-debug): Fix docstring. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 0597837ebd..2f9738a7e2 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -62,8 +62,8 @@ This is intended for debugging the compiler itself. 0 no debugging output. This is the recommended value unless you are debugging the compiler itself. 1 emit debug symbols and dump pseudo C code. - 2 dump gcc passes and libgccjit log file. - 3 dump libgccjit reproducers." + 2 dump gcc passes. + 3 dump libgccjit log file." :type 'integer :safe #'natnump :version "28.1") commit 79b8b6ca45ad707d86244882430e275efd95cdb9 Author: Andrea Corallo Date: Fri Mar 26 08:06:09 2021 +0100 * Prevent stale eln loading checking file timestamp before load (bug#46617) * src/lread.c (maybe_swap_for_eln): Add file timestamp check. (openp): Update 'maybe_swap_for_eln' call sites. diff --git a/src/lread.c b/src/lread.c index 56717dba81..e8c257a13c 100644 --- a/src/lread.c +++ b/src/lread.c @@ -1649,7 +1649,8 @@ directories, make sure the PREDICATE function returns `dir-ok' for them. */) If found replace the content of FILENAME and FD. */ static void -maybe_swap_for_eln (bool no_native, Lisp_Object *filename, int *fd) +maybe_swap_for_eln (bool no_native, Lisp_Object *filename, int *fd, + struct timespec mtime) { #ifdef HAVE_NATIVE_COMP struct stat eln_st; @@ -1686,13 +1687,19 @@ maybe_swap_for_eln (bool no_native, Lisp_Object *filename, int *fd) emacs_close (eln_fd); else { - *filename = eln_name; - emacs_close (*fd); - *fd = eln_fd; - /* Store the eln -> el relation. */ - Fputhash (Ffile_name_nondirectory (eln_name), - src_name, Vcomp_eln_to_el_h); - return; + struct timespec eln_mtime = get_stat_mtime (&eln_st); + if (timespec_cmp (eln_mtime, mtime) >= 0) + { + *filename = eln_name; + emacs_close (*fd); + *fd = eln_fd; + /* Store the eln -> el relation. */ + Fputhash (Ffile_name_nondirectory (eln_name), + src_name, Vcomp_eln_to_el_h); + return; + } + else + emacs_close (eln_fd); } } } @@ -1940,7 +1947,8 @@ openp (Lisp_Object path, Lisp_Object str, Lisp_Object suffixes, } else { - maybe_swap_for_eln (no_native, &string, &fd); + maybe_swap_for_eln (no_native, &string, &fd, + get_stat_mtime (&st)); /* We succeeded; return this descriptor and filename. */ if (storeptr) *storeptr = string; @@ -1952,7 +1960,8 @@ openp (Lisp_Object path, Lisp_Object str, Lisp_Object suffixes, /* No more suffixes. Return the newest. */ if (0 <= save_fd && ! CONSP (XCDR (tail))) { - maybe_swap_for_eln (no_native, &save_string, &save_fd); + maybe_swap_for_eln (no_native, &save_string, &save_fd, + save_mtime); if (storeptr) *storeptr = save_string; SAFE_FREE (); commit c6c7b30e4b46bf0c8ac5e77546d3938e79f14d56 Merge: 92914ade6d 52a7460416 Author: Andrea Corallo Date: Thu Mar 25 16:29:07 2021 +0100 Merge remote-tracking branch 'savannah/master' into native-comp commit 92914ade6d3c74ab0a1a7b3820e4707fb0679977 Author: Andrea Corallo Date: Wed Mar 24 16:59:52 2021 +0100 Improve two native compiler related docstrings. * lisp/emacs-lisp/comp.el (comp-eln-load-path-eff): Improve docstring. * src/comp.c (comp-eln-load-path): Likewise. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 90e127d632..0597837ebd 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -3692,7 +3692,7 @@ Prepare every function for final compilation and drive the C back-end." (defun comp-eln-load-path-eff () "Return a list of effective eln load directories. -Account for `comp-load-path' and `comp-native-version-dir'." +Account for `comp-eln-load-path' and `comp-native-version-dir'." (mapcar (lambda (dir) (expand-file-name comp-native-version-dir (file-name-as-directory diff --git a/src/comp.c b/src/comp.c index 5eb7bf2106..857f798a8d 100644 --- a/src/comp.c +++ b/src/comp.c @@ -5354,6 +5354,8 @@ For internal use. */); If a directory is non absolute is assumed to be relative to `invocation-directory'. +`comp-native-version-dir' value is used as a sub-folder name inside +each eln cache directory. The last directory of this list is assumed to be the system one. */); /* Temporary value in use for bootstrap. We can't do better as commit 4a3b43f55cfa96f5dd42e360eb4577750e97dbf0 Author: Andrea Corallo Date: Wed Mar 24 11:23:00 2021 +0100 * src/lread.c (maybe_swap_for_eln): Fix eln filename (bug#bug#47337). diff --git a/src/lread.c b/src/lread.c index 5fd52feb37..56717dba81 100644 --- a/src/lread.c +++ b/src/lread.c @@ -1675,7 +1675,9 @@ maybe_swap_for_eln (bool no_native, Lisp_Object *filename, int *fd) FOR_EACH_TAIL_SAFE (eln_path_tail) { Lisp_Object eln_name = - Fexpand_file_name (eln_rel_name, XCAR (eln_path_tail)); + Fexpand_file_name (eln_rel_name, + Fexpand_file_name (Vcomp_native_version_dir, + XCAR (eln_path_tail))); int eln_fd = emacs_open (SSDATA (ENCODE_FILE (eln_name)), O_RDONLY, 0); if (eln_fd > 0) commit 7ba816ee1cba00cf29cc79f60e731d86c8dc3a07 Author: Andrea Corallo Date: Sun Mar 21 21:55:13 2021 +0100 * lisp/emacs-lisp/comp.el (comp-lookup-eln): Add autoload cookie. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index e688d41f5d..90e127d632 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -4099,6 +4099,7 @@ bytecode definition was not changed in the meantime)." ;;; Compiler entry points. +;;;###autoload (defun comp-lookup-eln (filename) "Given a Lisp source FILENAME return the corresponding .eln file if found. Search happens in `comp-eln-load-path'." commit 5ae0a728c02045d274e61cc8c9290e827b0fadb8 Author: Andrea Corallo Date: Sun Mar 21 21:49:03 2021 +0100 ; * src/comp.c (Fcomp_el_to_eln_filename): Improve docstring. diff --git a/src/comp.c b/src/comp.c index 4e2b941b67..5eb7bf2106 100644 --- a/src/comp.c +++ b/src/comp.c @@ -4086,7 +4086,8 @@ DEFUN ("comp-el-to-eln-rel-filename", Fcomp_el_to_eln_rel_filename, DEFUN ("comp-el-to-eln-filename", Fcomp_el_to_eln_filename, Scomp_el_to_eln_filename, 1, 2, 0, - doc: /* Return the corresponding .eln filename for source FILENAME. + doc: /* Return the .eln filename for source FILENAME to used +for new compilations. If BASE-DIR is nil use the first entry in `comp-eln-load-path'. */) (Lisp_Object filename, Lisp_Object base_dir) { commit 6351953dcd162d46fcccfaeb0076d22e2a390951 Author: Andrea Corallo Date: Sun Mar 21 21:24:26 2021 +0100 * lisp/emacs-lisp/comp.el (comp-lookup-eln): Add new function. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 37b61edeb0..e688d41f5d 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -4099,6 +4099,20 @@ bytecode definition was not changed in the meantime)." ;;; Compiler entry points. +(defun comp-lookup-eln (filename) + "Given a Lisp source FILENAME return the corresponding .eln file if found. +Search happens in `comp-eln-load-path'." + (cl-loop + with eln-filename = (comp-el-to-eln-rel-filename filename) + for dir in comp-eln-load-path + for f = (expand-file-name eln-filename + (expand-file-name comp-native-version-dir + (expand-file-name + dir + invocation-directory))) + when (file-exists-p f) + do (cl-return f))) + ;;;###autoload (defun native-compile (function-or-file &optional output) "Compile FUNCTION-OR-FILE into native code. commit 5aa42f686c635e3b3f6cea8270e3c6fc2e4270f9 Author: Andrea Corallo Date: Sun Mar 21 20:40:45 2021 +0100 Prevent unnecessary multiple .el hashing in 'maybe_swap_for_eln' * src/comp.c (Fcomp_el_to_eln_rel_filename): New function. (Fcomp_el_to_eln_filename): Make use of. (syms_of_comp): Register 'Scomp_el_to_eln_rel_filename'. * src/lread.c (maybe_swap_for_eln): Make use of 'Fcomp_el_to_eln_rel_filename' to hash prevent unnecessary multiple hashing. diff --git a/src/comp.c b/src/comp.c index 29b16c78ac..4e2b941b67 100644 --- a/src/comp.c +++ b/src/comp.c @@ -4001,11 +4001,10 @@ make_directory_wrapper_1 (Lisp_Object ignore) return Qt; } -DEFUN ("comp-el-to-eln-filename", Fcomp_el_to_eln_filename, - Scomp_el_to_eln_filename, 1, 2, 0, - doc: /* Return the corresponding .eln filename for source FILENAME. -If BASE-DIR is nil use the first entry in `comp-eln-load-path'. */) - (Lisp_Object filename, Lisp_Object base_dir) +DEFUN ("comp-el-to-eln-rel-filename", Fcomp_el_to_eln_rel_filename, + Scomp_el_to_eln_rel_filename, 1, 1, 0, + doc: /* Return the corresponding .eln relative filename. */) + (Lisp_Object filename) { CHECK_STRING (filename); @@ -4082,7 +4081,16 @@ If BASE-DIR is nil use the first entry in `comp-eln-load-path'. */) make_fixnum (-3))), separator); Lisp_Object hash = concat3 (path_hash, separator, content_hash); - filename = concat3 (filename, hash, build_string (NATIVE_ELISP_SUFFIX)); + return concat3 (filename, hash, build_string (NATIVE_ELISP_SUFFIX)); +} + +DEFUN ("comp-el-to-eln-filename", Fcomp_el_to_eln_filename, + Scomp_el_to_eln_filename, 1, 2, 0, + doc: /* Return the corresponding .eln filename for source FILENAME. +If BASE-DIR is nil use the first entry in `comp-eln-load-path'. */) + (Lisp_Object filename, Lisp_Object base_dir) +{ + filename = Fcomp_el_to_eln_rel_filename (filename); /* If base_dir was not specified search inside Vcomp_eln_load_path for the first directory where we have write access. */ @@ -5287,6 +5295,7 @@ compiled one. */); "configuration, please recompile")); defsubr (&Scomp__subr_signature); + defsubr (&Scomp_el_to_eln_rel_filename); defsubr (&Scomp_el_to_eln_filename); defsubr (&Scomp_native_driver_options_effective_p); defsubr (&Scomp__install_trampoline); diff --git a/src/lread.c b/src/lread.c index 3bf3150006..5fd52feb37 100644 --- a/src/lread.c +++ b/src/lread.c @@ -1661,19 +1661,21 @@ maybe_swap_for_eln (bool no_native, Lisp_Object *filename, int *fd) /* Search eln in the eln-cache directories. */ Lisp_Object eln_path_tail = Vcomp_eln_load_path; - FOR_EACH_TAIL_SAFE (eln_path_tail) + Lisp_Object src_name = + Fsubstring (*filename, Qnil, make_fixnum (-1)); + if (NILP (Ffile_exists_p (src_name))) { - Lisp_Object src_name = - Fsubstring (*filename, Qnil, make_fixnum (-1)); + src_name = concat2 (src_name, build_string (".gz")); if (NILP (Ffile_exists_p (src_name))) - { - src_name = concat2 (src_name, build_string (".gz")); - if (NILP (Ffile_exists_p (src_name))) - /* Can't find the corresponding source file. */ - return; - } + /* Can't find the corresponding source file. */ + return; + } + Lisp_Object eln_rel_name = Fcomp_el_to_eln_rel_filename (src_name); + + FOR_EACH_TAIL_SAFE (eln_path_tail) + { Lisp_Object eln_name = - Fcomp_el_to_eln_filename (src_name, XCAR (eln_path_tail)); + Fexpand_file_name (eln_rel_name, XCAR (eln_path_tail)); int eln_fd = emacs_open (SSDATA (ENCODE_FILE (eln_name)), O_RDONLY, 0); if (eln_fd > 0) commit ec12cdd19732d9ad2be313cc93c17766ec62118f Author: Andrea Corallo Date: Sun Mar 21 19:39:52 2021 +0100 ; * test/Makefile.in (TEST_HOME): Add a note. diff --git a/test/Makefile.in b/test/Makefile.in index cb86f8e297..3cfd60d46c 100644 --- a/test/Makefile.in +++ b/test/Makefile.in @@ -120,6 +120,8 @@ emacs = LANG=C EMACSLOADPATH= \ # Set HOME to a nonexistent directory to prevent tests from accessing # it accidentally (e.g., popping up a gnupg dialog if ~/.authinfo.gpg # exists, or writing to ~/.bzr.log when running bzr commands). +# NOTE if the '/nonexistent' name is changed `normal-top-level' in +# startup.el must be updated too. TEST_HOME = /nonexistent test_module_dir := src/emacs-module-resources commit af739863b0a5fd3bbff048faef59b8feef45cca6 Author: Andrea Corallo Date: Sun Mar 21 16:55:19 2021 +0100 Add a tmp dir to `comp-eln-load-path' when running the testsuite. * lisp/startup.el (normal-top-level): Tweak `comp-eln-load-path' adding a temp directory when running the testsuite. diff --git a/lisp/startup.el b/lisp/startup.el index 7e8fa47aea..3e39ebc6e2 100644 --- a/lisp/startup.el +++ b/lisp/startup.el @@ -537,13 +537,19 @@ It is the default value of the variable `top-level'." (startup--xdg-or-homedot startup--xdg-config-home-emacs nil)) (when (featurep 'nativecomp) + ;; Form `comp-eln-load-path'. (defvar comp-eln-load-path) (let ((path-env (getenv "EMACSNATIVELOADPATH"))) (when path-env (dolist (path (split-string path-env path-separator)) (unless (string= "" path) (push path comp-eln-load-path))))) - (push (concat user-emacs-directory "eln-cache/") comp-eln-load-path)) + (push (concat user-emacs-directory "eln-cache/") comp-eln-load-path) + ;; When $HOME is set to '/nonexistent' means we are running the + ;; testsuite, add a temporary folder in front to produce there + ;; new compilations. + (when (equal (getenv "HOME") "/nonexistent") + (push (make-temp-file "emacs-testsuite-" t) comp-eln-load-path))) ;; Look in each dir in load-path for a subdirs.el file. If we ;; find one, load it, which will add the appropriate subdirs of ;; that dir into load-path. This needs to be done before setting commit d0280ce1b160ddc440d4ecac0397c50d2f5235eb Author: Andrea Corallo Date: Sun Mar 21 15:32:52 2021 +0100 Revert "* lisp/emacs-lisp/comp.el (comp-clean-up-stale-eln): Clean-up all..." This reverts commit be22cda7be9e77e67f224f6f07cca9dd44aaa078. Older binaries might still need those .eln if they where preloaded. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 76b4733cfa..37b61edeb0 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -3776,14 +3776,11 @@ sharing the original source filename (including FILE)." with filename-hash = (match-string 1 file) with regexp = (rx-to-string `(seq "-" ,filename-hash "-" (1+ hex) ".eln" eos)) - for dir in (comp-eln-load-path-eff) + for dir in (butlast (comp-eln-load-path-eff)) ; Skip last dir. do (cl-loop for f in (when (file-exists-p dir) (directory-files dir t regexp t)) - ;; We may not be able to delete de file if we have no write - ;; permisison. - do (ignore-error file-error - (comp-delete-or-replace-file f)))))) + do (comp-delete-or-replace-file f))))) (defun comp-delete-or-replace-file (oldfile &optional newfile) "Replace OLDFILE with NEWFILE. commit 08682ccc3154eaae993dbcb71a6498d1c06d80ae Author: Andrea Corallo Date: Sun Mar 21 09:28:25 2021 +0100 ; Remove two unnecessary quotes * lisp/emacs-lisp/comp-cstr.el (comp-cstr-=): Remove unnecessary quote. * lisp/emacs-lisp/comp.el (comp-compile-ctxt-to-file): Likewise. diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el index d0b842e7c3..7f5d34b45c 100644 --- a/lisp/emacs-lisp/comp-cstr.el +++ b/lisp/emacs-lisp/comp-cstr.el @@ -873,7 +873,7 @@ Non memoized version of `comp-cstr-intersection-no-mem'." for v in (valset cstr) do (when-let* ((ok (floatp v)) - (truncated (ignore-error 'overflow-error + (truncated (ignore-error overflow-error (truncate v))) (ok (= v truncated))) (push (cons truncated truncated) (range cstr)))) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index ca4be0fe97..76b4733cfa 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -3606,7 +3606,7 @@ Prepare every function for final compilation and drive the C back-end." (comp-ctxt-funcs-h comp-ctxt)) (unless (file-exists-p dir) ;; In case it's created in the meanwhile. - (ignore-error 'file-already-exists + (ignore-error file-already-exists (make-directory dir t))) (comp--compile-ctxt-to-file name))) commit be22cda7be9e77e67f224f6f07cca9dd44aaa078 Author: Andrea Corallo Date: Sun Mar 21 09:15:25 2021 +0100 * lisp/emacs-lisp/comp.el (comp-clean-up-stale-eln): Clean-up all .eln dirs. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 6da1a7979c..ca4be0fe97 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -3776,11 +3776,14 @@ sharing the original source filename (including FILE)." with filename-hash = (match-string 1 file) with regexp = (rx-to-string `(seq "-" ,filename-hash "-" (1+ hex) ".eln" eos)) - for dir in (butlast (comp-eln-load-path-eff)) ; Skip last dir. + for dir in (comp-eln-load-path-eff) do (cl-loop for f in (when (file-exists-p dir) (directory-files dir t regexp t)) - do (comp-delete-or-replace-file f))))) + ;; We may not be able to delete de file if we have no write + ;; permisison. + do (ignore-error file-error + (comp-delete-or-replace-file f)))))) (defun comp-delete-or-replace-file (oldfile &optional newfile) "Replace OLDFILE with NEWFILE. commit 6ca6c71cd0bf8fc970d9b1477ea61a670469f672 Merge: b3ad62f8a3 3af2cee64b Author: Andrea Corallo Date: Fri Mar 19 15:28:00 2021 +0100 Merge remote-tracking branch 'savannah/master' into native-comp commit b3ad62f8a35617366886be2a86e8641282824adf Author: Andrea Corallo Date: Fri Mar 19 10:23:41 2021 +0100 Do not load native code when `load' is explicitly called on a .elc file * src/lread.c (Fload): Do not load native code when `load' is explicitly called on a .elc file. (Flocate_file_internal): Update 'openp' call sites. (maybe_swap_for_eln): Add new 'no_native' parameter. (openp): Likewise + update 'maybe_swap_for_eln' and 'openp' call sites. * src/lisp.h: Update 'openp' signature. * src/w32proc.c (sys_spawnve): Update 'openp' call sites. * src/w32.c (check_windows_init_file): Likewise. * src/sound.c (Fplay_sound_internal): Likewise. * src/process.c (Fmake_process): Likewise. * src/image.c (image_create_bitmap_from_file) (image_find_image_fd): Likewise. * src/emacs.c (set_invocation_vars): Likewise. * src/charset.c (load_charset_map_from_file): Likewise. * src/callproc.c (call_process): Likewise. diff --git a/src/callproc.c b/src/callproc.c index cd0f67fe29..5aa2cbafb4 100644 --- a/src/callproc.c +++ b/src/callproc.c @@ -457,7 +457,7 @@ call_process (ptrdiff_t nargs, Lisp_Object *args, int filefd, int ok; ok = openp (Vexec_path, args[0], Vexec_suffixes, &path, - make_fixnum (X_OK), false); + make_fixnum (X_OK), false, false); if (ok < 0) report_file_error ("Searching for program", args[0]); } diff --git a/src/charset.c b/src/charset.c index eb388d1868..7cd0fa78f0 100644 --- a/src/charset.c +++ b/src/charset.c @@ -486,7 +486,7 @@ load_charset_map_from_file (struct charset *charset, Lisp_Object mapfile, ptrdiff_t count = SPECPDL_INDEX (); record_unwind_protect_nothing (); specbind (Qfile_name_handler_alist, Qnil); - fd = openp (Vcharset_map_path, mapfile, suffixes, NULL, Qnil, false); + fd = openp (Vcharset_map_path, mapfile, suffixes, NULL, Qnil, false, false); fp = fd < 0 ? 0 : fdopen (fd, "r"); if (!fp) { diff --git a/src/emacs.c b/src/emacs.c index ec62c19e38..d353679b0f 100644 --- a/src/emacs.c +++ b/src/emacs.c @@ -468,8 +468,9 @@ set_invocation_vars (char *argv0, char const *original_pwd) if (NILP (Vinvocation_directory)) { Lisp_Object found; - int yes = openp (Vexec_path, Vinvocation_name, - Vexec_suffixes, &found, make_fixnum (X_OK), false); + int yes = + openp (Vexec_path, Vinvocation_name, Vexec_suffixes, &found, + make_fixnum (X_OK), false, false); if (yes == 1) { /* Add /: to the front of the name diff --git a/src/image.c b/src/image.c index 6d493f6cdd..2f85e3035e 100644 --- a/src/image.c +++ b/src/image.c @@ -519,7 +519,7 @@ image_create_bitmap_from_file (struct frame *f, Lisp_Object file) /* Search bitmap-file-path for the file, if appropriate. */ if (openp (Vx_bitmap_file_path, file, Qnil, &found, - make_fixnum (R_OK), false) + make_fixnum (R_OK), false, false) < 0) return -1; @@ -3128,7 +3128,7 @@ image_find_image_fd (Lisp_Object file, int *pfd) /* Try to find FILE in data-directory/images, then x-bitmap-file-path. */ fd = openp (search_path, file, Qnil, &file_found, - pfd ? Qt : make_fixnum (R_OK), false); + pfd ? Qt : make_fixnum (R_OK), false, false); if (fd >= 0 || fd == -2) { file_found = ENCODE_FILE (file_found); diff --git a/src/lisp.h b/src/lisp.h index fcdf8e2718..4004b535cd 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -4087,7 +4087,7 @@ extern bool suffix_p (Lisp_Object, const char *); extern Lisp_Object save_match_data_load (Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object); extern int openp (Lisp_Object, Lisp_Object, Lisp_Object, - Lisp_Object *, Lisp_Object, bool); + Lisp_Object *, Lisp_Object, bool, bool); enum { S2N_IGNORE_TRAILING = 1 }; extern Lisp_Object string_to_number (char const *, int, ptrdiff_t *); extern void map_obarray (Lisp_Object, void (*) (Lisp_Object, Lisp_Object), diff --git a/src/lread.c b/src/lread.c index 989b55c88f..3bf3150006 100644 --- a/src/lread.c +++ b/src/lread.c @@ -1240,6 +1240,8 @@ Return t if the file exists and loads successfully. */) else file = Fsubstitute_in_file_name (file); + bool no_native = suffix_p (file, ".elc"); + /* Avoid weird lossage with null string as arg, since it would try to load a directory as a Lisp file. */ if (SCHARS (file) == 0) @@ -1280,7 +1282,9 @@ Return t if the file exists and loads successfully. */) suffixes = CALLN (Fappend, suffixes, Vload_file_rep_suffixes); } - fd = openp (Vload_path, file, suffixes, &found, Qnil, load_prefer_newer); + fd = + openp (Vload_path, file, suffixes, &found, Qnil, load_prefer_newer, + no_native); } if (fd == -1) @@ -1635,7 +1639,7 @@ directories, make sure the PREDICATE function returns `dir-ok' for them. */) (Lisp_Object filename, Lisp_Object path, Lisp_Object suffixes, Lisp_Object predicate) { Lisp_Object file; - int fd = openp (path, filename, suffixes, &file, predicate, false); + int fd = openp (path, filename, suffixes, &file, predicate, false, false); if (NILP (predicate) && fd >= 0) emacs_close (fd); return file; @@ -1645,12 +1649,13 @@ directories, make sure the PREDICATE function returns `dir-ok' for them. */) If found replace the content of FILENAME and FD. */ static void -maybe_swap_for_eln (Lisp_Object *filename, int *fd) +maybe_swap_for_eln (bool no_native, Lisp_Object *filename, int *fd) { #ifdef HAVE_NATIVE_COMP struct stat eln_st; - if (load_no_native + if (no_native + || load_no_native || !suffix_p (*filename, ".elc")) return; @@ -1714,11 +1719,14 @@ maybe_swap_for_eln (Lisp_Object *filename, int *fd) If NEWER is true, try all SUFFIXes and return the result for the newest file that exists. Does not apply to remote files, - or if a non-nil and non-t PREDICATE is specified. */ + or if a non-nil and non-t PREDICATE is specified. + + if NO_NATIVE is true do not try to load native code. */ int openp (Lisp_Object path, Lisp_Object str, Lisp_Object suffixes, - Lisp_Object *storeptr, Lisp_Object predicate, bool newer) + Lisp_Object *storeptr, Lisp_Object predicate, bool newer, + bool no_native) { ptrdiff_t fn_size = 100; char buf[100]; @@ -1928,7 +1936,7 @@ openp (Lisp_Object path, Lisp_Object str, Lisp_Object suffixes, } else { - maybe_swap_for_eln (&string, &fd); + maybe_swap_for_eln (no_native, &string, &fd); /* We succeeded; return this descriptor and filename. */ if (storeptr) *storeptr = string; @@ -1940,7 +1948,7 @@ openp (Lisp_Object path, Lisp_Object str, Lisp_Object suffixes, /* No more suffixes. Return the newest. */ if (0 <= save_fd && ! CONSP (XCDR (tail))) { - maybe_swap_for_eln (&save_string, &save_fd); + maybe_swap_for_eln (no_native, &save_string, &save_fd); if (storeptr) *storeptr = save_string; SAFE_FREE (); diff --git a/src/process.c b/src/process.c index b98bc297a3..84e301a87a 100644 --- a/src/process.c +++ b/src/process.c @@ -1936,7 +1936,7 @@ usage: (make-process &rest ARGS) */) { tem = Qnil; openp (Vexec_path, program, Vexec_suffixes, &tem, - make_fixnum (X_OK), false); + make_fixnum (X_OK), false, false); if (NILP (tem)) report_file_error ("Searching for program", program); tem = Fexpand_file_name (tem, Qnil); diff --git a/src/sound.c b/src/sound.c index e5f66f8f52..9041076bdc 100644 --- a/src/sound.c +++ b/src/sound.c @@ -1370,8 +1370,9 @@ Internal use only, use `play-sound' instead. */) if (STRINGP (attrs[SOUND_FILE])) { /* Open the sound file. */ - current_sound->fd = openp (list1 (Vdata_directory), - attrs[SOUND_FILE], Qnil, &file, Qnil, false); + current_sound->fd = + openp (list1 (Vdata_directory), attrs[SOUND_FILE], Qnil, &file, Qnil, + false, false); if (current_sound->fd < 0) sound_perror ("Could not open sound file"); diff --git a/src/w32.c b/src/w32.c index 14b8b11da0..467e6cb427 100644 --- a/src/w32.c +++ b/src/w32.c @@ -10255,7 +10255,8 @@ check_windows_init_file (void) need to ENCODE_FILE here, but we do need to convert the file names from UTF-8 to ANSI. */ init_file = build_string ("term/w32-win"); - fd = openp (Vload_path, init_file, Fget_load_suffixes (), NULL, Qnil, 0); + fd = + openp (Vload_path, init_file, Fget_load_suffixes (), NULL, Qnil, 0, 0); if (fd < 0) { Lisp_Object load_path_print = Fprin1_to_string (Vload_path, Qnil); diff --git a/src/w32proc.c b/src/w32proc.c index a50c87777f..ffa56e135d 100644 --- a/src/w32proc.c +++ b/src/w32proc.c @@ -1918,7 +1918,8 @@ sys_spawnve (int mode, char *cmdname, char **argv, char **envp) { program = build_string (cmdname); full = Qnil; - openp (Vexec_path, program, Vexec_suffixes, &full, make_fixnum (X_OK), 0); + openp (Vexec_path, program, Vexec_suffixes, &full, make_fixnum (X_OK), + 0, 0); if (NILP (full)) { errno = EINVAL; commit 3e133cc050926284109fe61f4789f67676491ffa Author: Andrea Corallo Date: Tue Mar 16 18:56:34 2021 +0100 Fix `no-byte-compile' native compilation interaction (bug#47169) * lisp/emacs-lisp/comp.el (comp-spill-lap-function): Throw no-native-compile when `byte-native-qualities' are null. * lisp/emacs-lisp/bytecomp.el (byte-compile-from-buffer): No need to consider `no-byte-compile'. diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 6b874b6916..b04286c34a 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -2277,8 +2277,7 @@ With argument ARG, insert value in current buffer after the form." (push `(comp-native-driver-options . ,comp-native-driver-options) byte-native-qualities) (defvar no-native-compile) - ;; `no-byte-compile' implies also `no-native-compile'. - (push `(no-native-compile . ,(or no-byte-compile no-native-compile)) + (push `(no-native-compile . ,no-native-compile) byte-native-qualities)) ;; Compile the forms from the input buffer. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index a3a481cd36..6da1a7979c 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1315,7 +1315,8 @@ clashes." (cl-defmethod comp-spill-lap-function ((filename string)) "Byte-compile FILENAME, spilling data from the byte compiler." (byte-compile-file filename) - (when (alist-get 'no-native-compile byte-native-qualities) + (when (or (null byte-native-qualities) + (alist-get 'no-native-compile byte-native-qualities)) (throw 'no-native-compile nil)) (unless byte-to-native-top-level-forms (signal 'native-compiler-error-empty-byte filename)) commit f3abb1711811f43d1504d8e48f0d27e015b46d6c Author: Andrea Corallo Date: Tue Mar 16 09:10:31 2021 +0100 Have `no-byte-compile' implies also `no-native-compile'. * lisp/emacs-lisp/comp.el (no-native-compile): Update doctring. * lisp/emacs-lisp/bytecomp.el (byte-compile-from-buffer): when `no-byte-compile' is set to non-nil it overrides this. diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index b04286c34a..6b874b6916 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -2277,7 +2277,8 @@ With argument ARG, insert value in current buffer after the form." (push `(comp-native-driver-options . ,comp-native-driver-options) byte-native-qualities) (defvar no-native-compile) - (push `(no-native-compile . ,no-native-compile) + ;; `no-byte-compile' implies also `no-native-compile'. + (push `(no-native-compile . ,(or no-byte-compile no-native-compile)) byte-native-qualities)) ;; Compile the forms from the input buffer. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 5a4a2f6ef1..a3a481cd36 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -182,6 +182,8 @@ the .eln output directory." (defvar no-native-compile nil "Non-nil to prevent native-compiling of Emacs Lisp code. +Note that when `no-byte-compile' is set to non-nil it overrides the value of +`no-native-compile'. This is normally set in local file variables at the end of the elisp file: \;; Local Variables:\n;; no-native-compile: t\n;; End: ") commit 6810635bdd109d3df5b6b946e8c9eb11035b579c Author: Eli Zaretskii Date: Mon Mar 15 19:24:20 2021 +0200 * lisp/emacs-lisp/byte-opt.el: Fix native re-compilation (bug#47161). diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el index db8d825cfe..436f5e48ae 100644 --- a/lisp/emacs-lisp/byte-opt.el +++ b/lisp/emacs-lisp/byte-opt.el @@ -2350,6 +2350,7 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." ;; (eval-when-compile (or (byte-code-function-p (symbol-function 'byte-optimize-form)) + (subr-native-elisp-p (symbol-function 'byte-optimize-form)) (assq 'byte-code (symbol-function 'byte-optimize-form)) (let ((byte-optimize nil) (byte-compile-warnings nil)) commit 7f74ed4912d845551209a5541c8919afbe19b884 Author: Andrea Corallo Date: Mon Mar 15 16:46:16 2021 +0100 * lisp/emacs-lisp/bytecomp.el: Fix native re-compilation (bug#47161). diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 921a25b35c..b04286c34a 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -5423,6 +5423,7 @@ and corresponding effects." ;; (eval-when-compile (or (byte-code-function-p (symbol-function 'byte-compile-form)) + (subr-native-elisp-p (symbol-function 'byte-compile-form)) (assq 'byte-code (symbol-function 'byte-compile-form)) (let ((byte-optimize nil) ; do it fast (byte-compile-warnings nil)) commit aabda4263bc2000a69e61e93a232e71f8afedec9 Author: Eli Zaretskii Date: Mon Mar 15 16:56:08 2021 +0200 Prefer expand-file-name to concat in native-compilation code * lisp/emacs-lisp/comp.el (comp-eln-load-path-eff): * src/comp.c (Fcomp_el_to_eln_filename) (eln_load_path_final_clean_up): Prefer expand-file-name to concat. (Bug#43725) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 97efd1ab0c..5a4a2f6ef1 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -3691,9 +3691,9 @@ Prepare every function for final compilation and drive the C back-end." "Return a list of effective eln load directories. Account for `comp-load-path' and `comp-native-version-dir'." (mapcar (lambda (dir) - (concat (file-name-as-directory - (expand-file-name dir invocation-directory)) - comp-native-version-dir)) + (expand-file-name comp-native-version-dir + (file-name-as-directory + (expand-file-name dir invocation-directory)))) comp-eln-load-path)) (defun comp-trampoline-filename (subr-name) diff --git a/src/comp.c b/src/comp.c index a79ee4ad87..29b16c78ac 100644 --- a/src/comp.c +++ b/src/comp.c @@ -4121,8 +4121,8 @@ If BASE-DIR is nil use the first entry in `comp-eln-load-path'. */) base_dir = Fexpand_file_name (base_dir, Vinvocation_directory); return Fexpand_file_name (filename, - concat2 (Ffile_name_as_directory (base_dir), - Vcomp_native_version_dir)); + Fexpand_file_name (Vcomp_native_version_dir, + base_dir)); } DEFUN ("comp--install-trampoline", Fcomp__install_trampoline, @@ -4613,8 +4613,8 @@ eln_load_path_final_clean_up (void) { Lisp_Object files_in_dir = internal_condition_case_5 (Fdirectory_files, - concat2 (XCAR (dir_tail), - Vcomp_native_version_dir), + Fexpand_file_name (Vcomp_native_version_dir, + XCAR (dir_tail)), Qt, build_string ("\\.eln\\.old\\'"), Qnil, Qnil, Qt, return_nil); FOR_EACH_TAIL (files_in_dir) commit 5e4ec4d3c944f586892e08ea4fb7715e0f6ac365 Author: Andrea Corallo Date: Sun Mar 14 21:54:06 2021 +0100 Fix some entry in `comp-known-type-specifiers' (bug#46847) * lisp/emacs-lisp/comp.el (comp-known-type-specifiers): Some fix. * test/src/comp-tests.el (comp-tests-46670-1): Update test. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 866ee8dcf7..97efd1ab0c 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -258,8 +258,8 @@ Useful to hook into pass checkers.") (>= (function ((or number marker) &rest (or number marker)) boolean)) (abs (function (number) number)) (acos (function (number) float)) - (append (function (&rest list) list)) - (aref (function (array fixnum) t)) + (append (function (&rest t) t)) + (aref (function (t fixnum) t)) (arrayp (function (t) boolean)) (ash (function (integer integer) integer)) (asin (function (number) float)) @@ -269,7 +269,7 @@ Useful to hook into pass checkers.") (bignump (function (t) boolean)) (bobp (function () boolean)) (bolp (function () boolean)) - (bool-vector-count-consecutive (function (bool-vector bool-vector integer) fixnum)) + (bool-vector-count-consecutive (function (bool-vector boolean integer) fixnum)) (bool-vector-count-population (function (bool-vector) fixnum)) (bool-vector-not (function (bool-vector &optional bool-vector) bool-vector)) (bool-vector-p (function (t) boolean)) @@ -384,7 +384,7 @@ Useful to hook into pass checkers.") (integer-or-marker-p (function (t) boolean)) (integerp (function (t) boolean)) (interactive-p (function () boolean)) - (intern-soft (function (string &optional vector) symbol)) + (intern-soft (function ((or string symbol) &optional vector) symbol)) (invocation-directory (function () string)) (invocation-name (function () string)) (isnan (function (float) boolean)) @@ -394,7 +394,7 @@ Useful to hook into pass checkers.") (last (function (list &optional integer) list)) (lax-plist-get (function (list t) t)) (ldexp (function (number integer) float)) - (length (function (sequence) integer)) + (length (function (t) (integer 0 *))) (length< (function (sequence fixnum) boolean)) (length= (function (sequence fixnum) boolean)) (length> (function (sequence fixnum) boolean)) @@ -441,7 +441,7 @@ Useful to hook into pass checkers.") (nlistp (function (t) boolean)) (not (function (t) boolean)) (nth (function (integer list) t)) - (nthcdr (function (integer list) list)) + (nthcdr (function (integer t) t)) (null (function (t) boolean)) (number-or-marker-p (function (t) boolean)) (number-to-string (function (number) string)) @@ -481,7 +481,7 @@ Useful to hook into pass checkers.") (sqrt (function (number) float)) (standard-case-table (function () char-table)) (standard-syntax-table (function () char-table)) - (string (function (&rest fixnum) strng)) + (string (function (&rest fixnum) string)) (string-as-multibyte (function (string) string)) (string-as-unibyte (function (string) string)) (string-equal (function ((or string symbol) (or string symbol)) boolean)) @@ -519,7 +519,7 @@ Useful to hook into pass checkers.") (type-of (function (t) symbol)) (unibyte-char-to-multibyte (function (fixnum) fixnum)) ;; byte is fixnum (upcase (function ((or fixnum string)) (or fixnum string))) - (user-full-name (function (&optional integer) string)) + (user-full-name (function (&optional integer) (or string null))) (user-login-name (function (&optional integer) (or string null))) (user-original-login-name (function (&optional integer) (or string null))) (user-real-login-name (function () string)) diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index f60e4ab049..b618110bbe 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -501,7 +501,7 @@ https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-03/msg00914.html." "" (should (string= (comp-test-46670-2-f "foo") "foo")) (should (equal (subr-type (symbol-function #'comp-test-46670-2-f)) - '(function (t) (or null sequence))))) + '(function (t) t)))) (comp-deftest 46824-1 () "" commit 472cd53d935a8dea3f15161287d27ee272345300 Author: Pip Cet Date: Sun Mar 14 12:13:40 2021 +0000 Don't call setjmp through a function pointer on Windows (bug#47067) * src/comp.c (ABI_VERSION): Bump. (emit_setjmp): Call setjmp directly. (declare_runtime_imported_funcs): Remove setjmp. (helper_link_table): Remove entry for setjmp. diff --git a/src/comp.c b/src/comp.c index 970c802267..a79ee4ad87 100644 --- a/src/comp.c +++ b/src/comp.c @@ -429,7 +429,7 @@ load_gccjit_if_necessary (bool mandatory) /* Increase this number to force a new Vcomp_abi_hash to be generated. */ -#define ABI_VERSION "3" +#define ABI_VERSION "4" /* Length of the hashes used for eln file naming. */ #define HASH_LENGTH 8 @@ -654,9 +654,6 @@ void *helper_link_table[] = helper_PSEUDOVECTOR_TYPEP_XUNTAG, pure_write_error, push_handler, -#ifdef WINDOWSNT - SETJMP_NAME, -#endif record_unwind_protect_excursion, helper_unbind_n, helper_save_restriction, @@ -1972,6 +1969,11 @@ emit_setjmp (gcc_jit_rvalue *buf) return gcc_jit_context_new_call (comp.ctxt, NULL, f, 1, args); #else /* _setjmp (buf, __builtin_frame_address (0)) */ + gcc_jit_param *params[] = + { + gcc_jit_context_new_param (comp.ctxt, NULL, comp.void_ptr_type, "buf"), + gcc_jit_context_new_param (comp.ctxt, NULL, comp.void_ptr_type, "frame"), + }; gcc_jit_rvalue *args[2]; args[0] = @@ -1985,8 +1987,14 @@ emit_setjmp (gcc_jit_rvalue *buf) "__builtin_frame_address"), 1, args); args[0] = buf; - return emit_call (intern_c_string (STR (SETJMP_NAME)), comp.int_type, 2, args, - false); + gcc_jit_function *f = + gcc_jit_context_new_function (comp.ctxt, NULL, + GCC_JIT_FUNCTION_IMPORTED, + comp.int_type, STR (SETJMP_NAME), + ARRAYELTS (params), params, + false); + + return gcc_jit_context_new_call (comp.ctxt, NULL, f, 2, args); #endif } @@ -2701,12 +2709,6 @@ declare_runtime_imported_funcs (void) args[1] = comp.int_type; ADD_IMPORTED (push_handler, comp.handler_ptr_type, 2, args); -#ifdef WINDOWSNT - args[0] = gcc_jit_type_get_pointer (gcc_jit_struct_as_type (comp.jmp_buf_s)); - args[1] = comp.void_ptr_type; - ADD_IMPORTED (SETJMP_NAME, comp.int_type, 2, args); -#endif - ADD_IMPORTED (record_unwind_protect_excursion, comp.void_type, 0, NULL); args[0] = comp.lisp_obj_type; commit f142f5ba46abed95c99e5dd55fb6f3a1af544148 Author: Eli Zaretskii Date: Sun Mar 14 15:36:39 2021 +0200 Fix hang due to failure to clean up *.eln.old files at exit * src/comp.c (eln_load_path_final_clean_up): Call internal_delete_file, not Fdelete_file, to ignore any errors. (Bug#46972) diff --git a/src/comp.c b/src/comp.c index 2ed893cbe0..970c802267 100644 --- a/src/comp.c +++ b/src/comp.c @@ -4616,7 +4616,7 @@ eln_load_path_final_clean_up (void) Qt, build_string ("\\.eln\\.old\\'"), Qnil, Qnil, Qt, return_nil); FOR_EACH_TAIL (files_in_dir) - Fdelete_file (XCAR (files_in_dir), Qnil); + internal_delete_file (XCAR (files_in_dir)); } #endif } commit d018584814e0c15f13bc458ba54491239b584069 Author: Andrea Corallo Date: Fri Mar 12 22:19:51 2021 +0100 * Fix circular dependecy when loading a modified comp.el (bug#47049) * lisp/emacs-lisp/comp.el (comp-subr-trampoline-install): Move it before other functional code. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index a62efc7e02..866ee8dcf7 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -648,6 +648,23 @@ Useful to hook into pass checkers.") 'native-compiler-error) +;; Moved early to avoid circularity when comp.el is loaded and +;; `macroexpand' needs to be advised (bug#47049). +;;;###autoload +(defun comp-subr-trampoline-install (subr-name) + "Make SUBR-NAME effectively advice-able when called from native code." + (unless (or (null comp-enable-subr-trampolines) + (memq subr-name comp-never-optimize-functions) + (gethash subr-name comp-installed-trampolines-h)) + (cl-assert (subr-primitive-p (symbol-function subr-name))) + (comp--install-trampoline + subr-name + (or (comp-trampoline-search subr-name) + (comp-trampoline-compile subr-name) + ;; Should never happen. + (cl-assert nil))))) + + (cl-defstruct (comp-vec (:copier nil)) "A re-sizable vector like object." (data (make-hash-table :test #'eql) :type hash-table @@ -3743,20 +3760,6 @@ Return the trampoline if found or nil otherwise." finally (error "Cannot find suitable directory for output in \ `comp-eln-load-path'"))))) -;;;###autoload -(defun comp-subr-trampoline-install (subr-name) - "Make SUBR-NAME effectively advice-able when called from native code." - (unless (or (null comp-enable-subr-trampolines) - (memq subr-name comp-never-optimize-functions) - (gethash subr-name comp-installed-trampolines-h)) - (cl-assert (subr-primitive-p (symbol-function subr-name))) - (comp--install-trampoline - subr-name - (or (comp-trampoline-search subr-name) - (comp-trampoline-compile subr-name) - ;; Should never happen. - (cl-assert nil))))) - ;; Some entry point support code. commit 82bd6d57d54d4cdb205d921c2476d1dbb17f4188 Merge: d9cd55a4f1 a0854f939c Author: Andrea Corallo Date: Fri Mar 12 16:42:51 2021 +0100 Merge remote-tracking branch 'savannah/master' into native-comp commit d9cd55a4f1c3f391b996dfbe77ed24306b37ac9f Author: Andrea Corallo Date: Fri Mar 12 10:24:29 2021 +0100 Implement `no-native-compile' (bug#46983) * lisp/emacs-lisp/bytecomp.el (byte-compile-from-buffer): Capture `no-native-compile'. * lisp/emacs-lisp/comp.el (no-native-compile): Define new variable. (comp-spill-lap-function): Throw when `no-native-compile' was captured non-nil. (comp--native-compile): Catch `no-native-compile' if necessary and return nil in case. diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 94424fc38a..8ca4adc6a9 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -2275,6 +2275,9 @@ With argument ARG, insert value in current buffer after the form." (push `(comp-debug . ,comp-debug) byte-native-qualities) (defvar comp-native-driver-options) (push `(comp-native-driver-options . ,comp-native-driver-options) + byte-native-qualities) + (defvar no-native-compile) + (push `(no-native-compile . ,no-native-compile) byte-native-qualities)) ;; Compile the forms from the input buffer. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 98f4dd6e1f..a62efc7e02 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -180,6 +180,13 @@ the .eln output directory." :type 'boolean :version "28.1") +(defvar no-native-compile nil + "Non-nil to prevent native-compiling of Emacs Lisp code. +This is normally set in local file variables at the end of the elisp file: + +\;; Local Variables:\n;; no-native-compile: t\n;; End: ") +;;;###autoload(put 'no-native-compile 'safe-local-variable 'booleanp) + (defvar comp-log-time-report nil "If non-nil, log a time report for each pass.") @@ -1289,6 +1296,8 @@ clashes." (cl-defmethod comp-spill-lap-function ((filename string)) "Byte-compile FILENAME, spilling data from the byte compiler." (byte-compile-file filename) + (when (alist-get 'no-native-compile byte-native-qualities) + (throw 'no-native-compile nil)) (unless byte-to-native-top-level-forms (signal 'native-compiler-error-empty-byte filename)) (unless (comp-ctxt-output comp-ctxt) @@ -3943,55 +3952,57 @@ load once it finishes compiling." (stringp function-or-file)) (signal 'native-compiler-error (list "Not a function symbol or file" function-or-file))) - (let* ((data function-or-file) - (comp-native-compiling t) - (byte-native-qualities nil) - ;; 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) + (catch 'no-native-compile + (let* ((data function-or-file) + (comp-native-compiling t) + (byte-native-qualities nil) + ;; 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) + 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)))) - (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)))) + 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))))) (defun native-compile-async-skip-p (file load selector) "Return non-nil if FILE's compilation should be skipped. commit 0144764d1dde8a2f1d413d042d46cea3e10a7d0a Author: Andrea Corallo Date: Fri Mar 12 08:59:55 2021 +0100 * Fix error reporting for async native compilation (bug#47024) * lisp/emacs-lisp/comp.el (comp--native-compile): During async compilation if we catch an error print it in a parsable way so we can report it to the user. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 3d2a345e21..98f4dd6e1f 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -3970,12 +3970,24 @@ load once it finishes compiling." (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-error - ;; Add source input. + (t (let ((err-val (cdr err))) - (signal (car err) (if (consp err-val) - (cons function-or-file err-val) - (list function-or-file err-val)))))) + ;; 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. commit 711b2c834976e41ca2c9c36dafcc9977eb4f398b Author: Andrea Corallo Date: Wed Mar 10 15:56:05 2021 +0100 * lisp/loadup.el: Don't load pcase on native builds (bug#47025). diff --git a/lisp/loadup.el b/lisp/loadup.el index 5b39152482..f65f7f1d30 100644 --- a/lisp/loadup.el +++ b/lisp/loadup.el @@ -157,7 +157,8 @@ ;; Load-time macro-expansion can only take effect after setting ;; load-source-file-function because of where it is called in lread.c. (load "emacs-lisp/macroexp") -(if (byte-code-function-p (symbol-function 'macroexpand-all)) +(if (or (byte-code-function-p (symbol-function 'macroexpand-all)) + (subr-native-elisp-p (symbol-function 'macroexpand-all))) nil ;; Since loaddefs is not yet loaded, macroexp's uses of pcase will simply ;; fail until pcase is explicitly loaded. This also means that we have to commit fe1c081c3881421841b1e1ce4847035fdcdd457b Author: Andrea Corallo Date: Wed Mar 10 15:50:58 2021 +0100 * Fix truncated warnings (bug#47024) * lisp/emacs-lisp/comp.el (comp-run-async-workers): Bind `warning-fill-column' to `most-positive-fixnum'. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 81ab361fff..3d2a345e21 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -3882,7 +3882,8 @@ display a message." comp-eln-load-path ',comp-eln-load-path comp-native-driver-options ',comp-native-driver-options - load-path ',load-path) + load-path ',load-path + warning-fill-column most-positive-fixnum) ,comp-async-env-modifier-form (message "Compiling %s..." ,source-file) (comp--native-compile ,source-file ,(and load t)))) commit 79c83f79c5b618cb9ef5eca7be2245f15ff54626 Author: Andrea Corallo Date: Tue Mar 9 16:35:13 2021 +0100 * src/comp.c (ABI_VERSION): Bump following-up 380ba045c4. diff --git a/src/comp.c b/src/comp.c index 9b7be5cce7..2ed893cbe0 100644 --- a/src/comp.c +++ b/src/comp.c @@ -429,7 +429,7 @@ load_gccjit_if_necessary (bool mandatory) /* Increase this number to force a new Vcomp_abi_hash to be generated. */ -#define ABI_VERSION "2" +#define ABI_VERSION "3" /* Length of the hashes used for eln file naming. */ #define HASH_LENGTH 8 commit 7672b15c2730d55cfc3aba1b83986721f932ba50 Author: Andrea Corallo Date: Tue Mar 9 12:06:28 2021 +0100 * test/src/comp-test-funcs.el (comp-test-46670-1-f): Remove a warning. diff --git a/test/src/comp-test-funcs.el b/test/src/comp-test-funcs.el index 08aa6bb472..cbd0e5747e 100644 --- a/test/src/comp-test-funcs.el +++ b/test/src/comp-test-funcs.el @@ -478,7 +478,7 @@ (eq family 'unspecified)) family))) -(defun comp-test-46670-1-f (x) +(defun comp-test-46670-1-f (_) "foo") (defun comp-test-46670-2-f (s) commit 43b0df62cd5922df5495b3f4aee5b7beca14384f Merge: 380ba045c4 9cbdf20316 Author: Andrea Corallo Date: Tue Mar 9 10:03:47 2021 +0100 Merge commit '9cbdf20316' into native-comp commit 380ba045c48bfbb160da288b1bd50f82d3f999f0 Author: Pip Cet Date: Mon Mar 8 20:49:59 2021 +0000 * Fix comp unit type decl in eln files to fix GC crash (bug#46256) * src/comp.c (emit_ctxt_code): Allocate comp_unit as a Lisp_Object, not a pointer to pointer to Lisp_Object. diff --git a/src/comp.c b/src/comp.c index e180978541..9b7be5cce7 100644 --- a/src/comp.c +++ b/src/comp.c @@ -2774,7 +2774,7 @@ emit_ctxt_code (void) comp.ctxt, NULL, GCC_JIT_GLOBAL_EXPORTED, - gcc_jit_type_get_pointer (comp.lisp_obj_ptr_type), + comp.lisp_obj_type, COMP_UNIT_SYM); declare_imported_data (); commit 93f92cf1ba37f8b9abaee4b9487705bae464c4e0 Author: Pip Cet Date: Sun Mar 7 21:26:29 2021 +0000 Zero stale pointer when unloading comp units (bug#46256) * src/alloc.c (cleanup_vector): Call unload_comp_unit. * src/comp.c (unload_comp_unit): New function. diff --git a/src/alloc.c b/src/alloc.c index af08336177..fee8cc08aa 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -3157,8 +3157,7 @@ cleanup_vector (struct Lisp_Vector *vector) { struct Lisp_Native_Comp_Unit *cu = PSEUDOVEC_STRUCT (vector, Lisp_Native_Comp_Unit); - eassert (cu->handle); - dynlib_close (cu->handle); + unload_comp_unit (cu); } else if (NATIVE_COMP_FLAG && PSEUDOVECTOR_TYPEP (&vector->header, PVEC_SUBR)) diff --git a/src/comp.c b/src/comp.c index e6f672de25..e180978541 100644 --- a/src/comp.c +++ b/src/comp.c @@ -4949,6 +4949,20 @@ load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u, bool loading_dump, return res; } +void +unload_comp_unit (struct Lisp_Native_Comp_Unit *cu) +{ + if (cu->handle == NULL) + return; + + Lisp_Object *saved_cu = dynlib_sym (cu->handle, COMP_UNIT_SYM); + Lisp_Object this_cu; + XSETNATIVE_COMP_UNIT (this_cu, cu); + if (EQ (this_cu, *saved_cu)) + *saved_cu = Qnil; + dynlib_close (cu->handle); +} + Lisp_Object native_function_doc (Lisp_Object function) { diff --git a/src/comp.h b/src/comp.h index f7d17f398c..d01bc17565 100644 --- a/src/comp.h +++ b/src/comp.h @@ -78,6 +78,8 @@ extern void hash_native_abi (void); extern Lisp_Object load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u, bool loading_dump, bool late_load); +extern void unload_comp_unit (struct Lisp_Native_Comp_Unit *); + extern Lisp_Object native_function_doc (Lisp_Object function); extern void syms_of_comp (void); commit 15aa239ba058ef02544e5dfaf066bd985d9b2f4f Author: Andrea Corallo Date: Sun Mar 7 21:56:06 2021 +0100 * Handle `comp-native-driver-options' both as file-local both as global * src/comp.c (add_driver_options): Throw an error if `comp-native-driver-options' is set globally but 'gcc_jit_context_add_driver_option' is not available, ignore for the file-local case. diff --git a/src/comp.c b/src/comp.c index b68adf31d6..e6f672de25 100644 --- a/src/comp.c +++ b/src/comp.c @@ -4334,9 +4334,9 @@ DEFUN ("comp-native-driver-options-effective-p", static void add_driver_options (void) { - Lisp_Object options = comp.driver_options; + Lisp_Object options = Fsymbol_value (Qcomp_native_driver_options); -#if defined (LIBGCCJIT_HAVE_gcc_jit_context_add_driver_option) \ +#if defined (LIBGCCJIT_HAVE_gcc_jit_context_add_driver_option) \ || defined (WINDOWSNT) load_gccjit_if_necessary (true); if (!NILP (Fcomp_native_driver_options_effective_p ())) @@ -4347,7 +4347,6 @@ add_driver_options (void) ENCODE_FILE or ENCODE_SYSTEM. */ SSDATA (XCAR (options))); - return; #endif if (CONSP (options)) xsignal1 (Qnative_compiler_error, @@ -4355,6 +4354,20 @@ add_driver_options (void) " via `comp-native-driver-options' is" " only available on libgccjit version 9" " and above.")); + + /* Captured `comp-native-driver-options' because file-local. */ +#if defined (LIBGCCJIT_HAVE_gcc_jit_context_add_driver_option) \ + || defined (WINDOWSNT) + options = comp.driver_options; + if (!NILP (Fcomp_native_driver_options_effective_p ())) + FOR_EACH_TAIL (options) + gcc_jit_context_add_driver_option (comp.ctxt, + /* FIXME: Need to encode + this, but how? either + ENCODE_FILE or + ENCODE_SYSTEM. */ + SSDATA (XCAR (options))); +#endif } DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, commit 9809f7ed2c639bd51abd4a28bd5d1a37f0d46a3d Author: Andrea Corallo Date: Sun Mar 7 21:26:55 2021 +0100 Use `length=' and family where possible in native comp code * lisp/emacs-lisp/comp-cstr.el (comp-intersect-typesets) (comp-cstr-imm): Use Use `length=' and family where possible. * lisp/emacs-lisp/comp.el (comp-add-cond-cstrs-target-block) (comp-compute-dominator-frontiers) (batch-byte-native-compile-for-bootstrap): Likewise. diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el index 4397a91498..d0b842e7c3 100644 --- a/lisp/emacs-lisp/comp-cstr.el +++ b/lisp/emacs-lisp/comp-cstr.el @@ -287,7 +287,7 @@ Return them as multiple value." (defun comp-intersect-typesets (&rest typesets) "Intersect types present into TYPESETS." (unless (cl-some #'null typesets) - (if (= (length typesets) 1) + (if (length= typesets 1) (car typesets) (comp-normalize-typeset (cl-reduce #'comp-intersect-two-typesets typesets))))) @@ -823,7 +823,7 @@ Non memoized version of `comp-cstr-intersection-no-mem'." (valset ,cstr) (list ,val))))))) (with-comp-cstr-accessors (let ((v (valset cstr))) - (if (= (length v) 1) + (if (length= v 1) (car v) (caar (range cstr)))))) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 7b2883b293..81ab361fff 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2364,7 +2364,7 @@ TARGET-BB-SYM is the symbol name of the target block." (comp-func-blocks comp-func))) (target-bb-in-edges (comp-block-in-edges target-bb))) (cl-assert target-bb-in-edges) - (if (= (length target-bb-in-edges) 1) + (if (length= target-bb-in-edges 1) ;; If block has only one predecessor is already suitable for ;; adding constraint assumptions. target-bb @@ -2780,7 +2780,7 @@ blocks." for b-name being each hash-keys of blocks using (hash-value b) for preds = (comp-block-preds b) - when (>= (length preds) 2) ; All joins + when (length> preds 1) ; All joins do (cl-loop for p in preds for runner = p do (while (not (eq runner (comp-block-idom b))) @@ -4104,7 +4104,7 @@ environment variable 'NATIVE_DISABLED' is set, only byte compile." (comp-ensure-native-compiler) (if (equal (getenv "NATIVE_DISABLED") "1") (batch-byte-compile) - (cl-assert (= 1 (length command-line-args-left))) + (cl-assert (length= command-line-args-left 1)) (let ((byte-native-for-bootstrap t) (byte-to-native-output-file nil)) (batch-native-compile) commit dcf2be69711be1240c09ba6f6f0482a7fcf4e21b Author: Andrea Corallo Date: Sun Mar 7 21:01:35 2021 +0100 ; * src/comp.c (load_comp_unit): Fix a comment. diff --git a/src/comp.c b/src/comp.c index b2d8b8ec98..b68adf31d6 100644 --- a/src/comp.c +++ b/src/comp.c @@ -4814,7 +4814,7 @@ load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u, bool loading_dump, /* 'dlopen' returns the same handle when trying to load two times the same shared. In this case touching 'd_reloc' etc leads to fails in case a frame with a reference to it in a live reg is - active (comp-speed >= 0). + active (comp-speed > 0). We must *never* mess with static pointers in an already loaded eln. */ commit b6f06c32b47be265865949e1f09df4768d5a87e1 Author: Andrea Corallo Date: Sun Mar 7 20:25:28 2021 +0100 * lisp/emacs-lisp/comp.el (w32-get-nproc): Suppress warning declaring it. For non Windows system. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index cedbb78623..7b2883b293 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -3818,6 +3818,7 @@ processes from `comp-async-compilations'" do (remhash file-name comp-async-compilations)) (hash-table-count comp-async-compilations)) +(declare-function w32-get-nproc "w32.c") (defvar comp-num-cpus nil) (defun comp-effective-async-max-jobs () "Compute the effective number of async jobs." commit dbdc44db15ef9daa24d92c59d4e158f3963a172f Author: Andrea Corallo Date: Sun Mar 7 20:19:20 2021 +0100 Allow for `comp-native-driver-options' to work as a file-local variable. diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 4169b0756d..3ee8113c4f 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -2272,7 +2272,10 @@ With argument ARG, insert value in current buffer after the form." (defvar comp-speed) (push `(comp-speed . ,comp-speed) byte-native-qualities) (defvar comp-debug) - (push `(comp-debug . ,comp-debug) byte-native-qualities)) + (push `(comp-debug . ,comp-debug) byte-native-qualities) + (defvar comp-native-driver-options) + (push `(comp-native-driver-options . ,comp-native-driver-options) + byte-native-qualities)) ;; Compile the forms from the input buffer. (while (progn diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 70e10644ca..cedbb78623 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -712,6 +712,8 @@ Returns ELT." :documentation "Default speed for this compilation unit.") (debug comp-debug :type number :documentation "Default debug level for this compilation unit.") + (driver-options comp-native-driver-options :type list + :documentation "Options for the GCC driver.") (top-level-forms () :type list :documentation "List of spilled top level forms.") (funcs-h (make-hash-table :test #'equal) :type hash-table @@ -1298,6 +1300,8 @@ clashes." byte-native-qualities) (comp-ctxt-debug comp-ctxt) (alist-get 'comp-debug byte-native-qualities) + (comp-ctxt-driver-options comp-ctxt) (alist-get 'comp-native-driver-options + byte-native-qualities) (comp-ctxt-top-level-forms comp-ctxt) (cl-loop for form in (reverse byte-to-native-top-level-forms) diff --git a/src/comp.c b/src/comp.c index bea9945bbf..b2d8b8ec98 100644 --- a/src/comp.c +++ b/src/comp.c @@ -516,6 +516,7 @@ typedef struct { typedef struct { EMACS_INT speed; EMACS_INT debug; + Lisp_Object driver_options; gcc_jit_context *ctxt; gcc_jit_type *void_type; gcc_jit_type *bool_type; @@ -4333,7 +4334,7 @@ DEFUN ("comp-native-driver-options-effective-p", static void add_driver_options (void) { - Lisp_Object options = Fsymbol_value (Qcomp_native_driver_options); + Lisp_Object options = comp.driver_options; #if defined (LIBGCCJIT_HAVE_gcc_jit_context_add_driver_option) \ || defined (WINDOWSNT) @@ -4400,6 +4401,7 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, eassert (comp.speed < INT_MAX); comp.debug = XFIXNUM (CALL1I (comp-ctxt-debug, Vcomp_ctxt)); eassert (comp.debug < INT_MAX); + comp.driver_options = CALL1I (comp-ctxt-driver-options, Vcomp_ctxt); if (comp.debug) gcc_jit_context_set_bool_option (comp.ctxt, commit 38b4ac3e6b5ac7e88003e02b30bbe2bdb82e6e6a Author: Andrea Corallo Date: Sun Mar 7 19:48:04 2021 +0100 * Work around GCC PR99126 on all libgccjit < 11 * src/comp.c (Fcomp__compile_ctxt_to_file): Work around GCC PR99126 on all libgccjit < 11. diff --git a/src/comp.c b/src/comp.c index 2322ce001b..bea9945bbf 100644 --- a/src/comp.c +++ b/src/comp.c @@ -4459,7 +4459,8 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, && (defined (LIBGCCJIT_HAVE_gcc_jit_context_add_command_line_option) \ || defined (WINDOWSNT)) Lisp_Object version = Fcomp_libgccjit_version (); - if (!NILP (version) && XFIXNUM (XCAR (version)) == 10) + if (NILP (version) + || XFIXNUM (XCAR (version)) < 11) gcc_jit_context_add_command_line_option (comp.ctxt, "-fdisable-tree-isolate-paths"); #endif commit 948e6609b11b0203d6e1d0fdfdcc23b8538f3e98 Author: Eli Zaretskii Date: Sun Mar 7 16:31:35 2021 +0200 Avoid aborts in native-comp subprocesses when exiting Emacs on Windows * src/w32.c (shutdown_handler): Clear the message stack when being shut down in noninteractive mode, to avoid aborting in shut_down_emacs when a native-compilation subprocess is killed because the parent Emacs exits. diff --git a/src/w32.c b/src/w32.c index 7ce907d0ad..14b8b11da0 100644 --- a/src/w32.c +++ b/src/w32.c @@ -10447,6 +10447,13 @@ shutdown_handler (DWORD type) || type == CTRL_LOGOFF_EVENT /* User logs off. */ || type == CTRL_SHUTDOWN_EVENT) /* User shutsdown. */ { + /* If we are being shut down in noninteractive mode, we don't + care about the message stack, so clear it to avoid abort in + shut_down_emacs. This happens when an noninteractive Emacs + is invoked as a subprocess of Emacs, and the parent wants to + kill us, e.g. because it's about to exit. */ + if (noninteractive) + clear_message_stack (); /* Shut down cleanly, making sure autosave files are up to date. */ shut_down_emacs (0, Qnil); } commit f89e70a7041b061eb40f2b5e0c58a28bfb84920f Author: Eli Zaretskii Date: Sun Mar 7 15:52:20 2021 +0200 Fix encoding of file names in comp.c * src/comp.c (Fcomp__compile_ctxt_to_file) [WINDOWSNT]: Fix encoding of file names passed to libgccjit. diff --git a/src/comp.c b/src/comp.c index 7927448d5f..2322ce001b 100644 --- a/src/comp.c +++ b/src/comp.c @@ -4371,6 +4371,7 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, comp.func_relocs_local = NULL; #ifdef WINDOWSNT + ebase_name = ansi_encode_filename (ebase_name); /* Tell libgccjit the actual file name of the loaded DLL, otherwise it will use 'libgccjit.so', which is not useful. */ Lisp_Object libgccjit_loaded_from = Fget (Qgccjit, QCloaded_from); @@ -4476,9 +4477,13 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, Lisp_Object tmp_file = Fmake_temp_file_internal (base_name, Qnil, build_string (".eln.tmp"), Qnil); + Lisp_Object encoded_tmp_file = ENCODE_FILE (tmp_file); +#ifdef WINDOWSNT + encoded_tmp_file = ansi_encode_filename (encoded_tmp_file); +#endif gcc_jit_context_compile_to_file (comp.ctxt, GCC_JIT_OUTPUT_KIND_DYNAMIC_LIBRARY, - SSDATA (ENCODE_FILE (tmp_file))); + SSDATA (encoded_tmp_file)); const char *err = gcc_jit_context_get_first_error (comp.ctxt); if (err) commit 619f66f423c76d94b2bca728f9c22b536e909108 Author: Eli Zaretskii Date: Sun Mar 7 15:32:55 2021 +0200 Use MS-Windows system APIs to get number of processors * lisp/emacs-lisp/comp.el: Use 'w32-get-nproc' instead of the environment variable NUMBER_OF_PROCESSORS. * src/w32proc.c (Fw32_get_nproc): New primitive. * src/w32.c (w32_get_nproc): New function. (sample_system_load): Call w32_get_nproc to initialize the number of processors on this system. * src/w32.h (w32_get_nproc): Add prototype. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 134b5a2808..70e10644ca 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -3824,8 +3824,7 @@ processes from `comp-async-compilations'" ;; the number of processors, see get_native_system_info in w32.c. ;; The result needs to be exported to Lisp. (max 1 (/ (cond ((eq 'windows-nt system-type) - (string-to-number (getenv - "NUMBER_OF_PROCESSORS"))) + (w32-get-nproc)) ((executable-find "nproc") (string-to-number (shell-command-to-string "nproc"))) diff --git a/src/w32.c b/src/w32.c index 96eba1e568..7ce907d0ad 100644 --- a/src/w32.c +++ b/src/w32.c @@ -1941,11 +1941,10 @@ buf_prev (int from) return prev_idx; } -static void -sample_system_load (ULONGLONG *idle, ULONGLONG *kernel, ULONGLONG *user) +unsigned +w32_get_nproc (void) { SYSTEM_INFO sysinfo; - FILETIME ft_idle, ft_user, ft_kernel; /* Initialize the number of processors on this machine. */ if (num_of_processors <= 0) @@ -1960,6 +1959,15 @@ sample_system_load (ULONGLONG *idle, ULONGLONG *kernel, ULONGLONG *user) if (num_of_processors <= 0) num_of_processors = 1; } + return num_of_processors; +} + +static void +sample_system_load (ULONGLONG *idle, ULONGLONG *kernel, ULONGLONG *user) +{ + FILETIME ft_idle, ft_user, ft_kernel; + + (void) w32_get_nproc (); /* TODO: Take into account threads that are ready to run, by sampling the "\System\Processor Queue Length" performance diff --git a/src/w32.h b/src/w32.h index 3f8eb250cc..a382dbe791 100644 --- a/src/w32.h +++ b/src/w32.h @@ -233,6 +233,9 @@ extern int w32_memory_info (unsigned long long *, unsigned long long *, /* Compare 2 UTF-8 strings in locale-dependent fashion. */ extern int w32_compare_strings (const char *, const char *, char *, int); +/* Return the number of processor execution units on this system. */ +extern unsigned w32_get_nproc (void); + /* Return a cryptographically secure seed for PRNG. */ extern int w32_init_random (void *, ptrdiff_t); diff --git a/src/w32proc.c b/src/w32proc.c index 2b6cb9c1e1..a50c87777f 100644 --- a/src/w32proc.c +++ b/src/w32proc.c @@ -3877,6 +3877,14 @@ w32_compare_strings (const char *s1, const char *s2, char *locname, return val - 2; } +DEFUN ("w32-get-nproc", Fw32_get_nproc, + Sw32_get_nproc, 0, 0, 0, + doc: /* Return the number of system's processor execution units. */) + (void) +{ + return make_fixnum (w32_get_nproc ()); +} + void syms_of_ntproc (void) @@ -3911,6 +3919,8 @@ syms_of_ntproc (void) defsubr (&Sw32_get_keyboard_layout); defsubr (&Sw32_set_keyboard_layout); + defsubr (&Sw32_get_nproc); + DEFVAR_LISP ("w32-quote-process-args", Vw32_quote_process_args, doc: /* Non-nil enables quoting of process arguments to ensure correct parsing. Because Windows does not directly pass argv arrays to child processes, commit 99638d128ee07fa35525ac47217f68dd518e9175 Author: Eli Zaretskii Date: Sun Mar 7 12:53:51 2021 +0200 ; * src/comp.c (Fcomp__compile_ctxt_to_file) [WINDOWSNT]: Fix last change. diff --git a/src/comp.c b/src/comp.c index d9ad623ec7..7927448d5f 100644 --- a/src/comp.c +++ b/src/comp.c @@ -4385,6 +4385,7 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, libgccjit_fname = XCAR (libgccjit_loaded_from); /* Must encode to ANSI, as libgccjit will not be able to handle UTF-8 encoded file names. */ + libgccjit_fname = ENCODE_FILE (libgccjit_fname); libgccjit_fname = ansi_encode_filename (libgccjit_fname); gcc_jit_context_set_str_option (comp.ctxt, GCC_JIT_STR_OPTION_PROGNAME, SSDATA (libgccjit_fname)); commit 7a13a0d616cde9f0f2a6fe217144e9891e769b61 Author: Eli Zaretskii Date: Sun Mar 7 12:49:05 2021 +0200 Fix libgccjit PROGNAME on MS-Windows * src/comp.c [WINDOWSNT]: Import gcc_jit_context_set_str_option. (init_gccjit_functions): Load gcc_jit_context_set_str_option. (gcc_jit_context_set_str_option) [WINDOWSNT]: New macro. (Fcomp__compile_ctxt_to_file) [WINDOWSNT]: Pass the actual name of the libgccjit DLL to the library, to be used as PROGNAME. diff --git a/src/comp.c b/src/comp.c index 94d3fa99a3..d9ad623ec7 100644 --- a/src/comp.c +++ b/src/comp.c @@ -89,6 +89,7 @@ along with GNU Emacs. If not, see . */ #undef gcc_jit_context_set_bool_option #undef gcc_jit_context_set_int_option #undef gcc_jit_context_set_logfile +#undef gcc_jit_context_set_str_option #undef gcc_jit_function_get_param #undef gcc_jit_function_new_block #undef gcc_jit_function_new_local @@ -248,6 +249,9 @@ DEF_DLL_FN (void, gcc_jit_context_set_int_option, (gcc_jit_context *ctxt, enum gcc_jit_int_option opt, int value)); DEF_DLL_FN (void, gcc_jit_context_set_logfile, (gcc_jit_context *ctxt, FILE *logfile, int flags, int verbosity)); +DEF_DLL_FN (void, gcc_jit_context_set_str_option, + (gcc_jit_context *ctxt, enum gcc_jit_str_option opt, + const char *value)); DEF_DLL_FN (void, gcc_jit_struct_set_fields, (gcc_jit_struct *struct_type, gcc_jit_location *loc, int num_fields, gcc_jit_field **fields)); @@ -304,6 +308,7 @@ init_gccjit_functions (void) LOAD_DLL_FN (library, gcc_jit_context_set_bool_option); LOAD_DLL_FN (library, gcc_jit_context_set_int_option); LOAD_DLL_FN (library, gcc_jit_context_set_logfile); + LOAD_DLL_FN (library, gcc_jit_context_set_str_option); LOAD_DLL_FN (library, gcc_jit_function_get_param); LOAD_DLL_FN (library, gcc_jit_function_new_block); LOAD_DLL_FN (library, gcc_jit_function_new_local); @@ -373,6 +378,7 @@ init_gccjit_functions (void) #define gcc_jit_context_set_bool_option fn_gcc_jit_context_set_bool_option #define gcc_jit_context_set_int_option fn_gcc_jit_context_set_int_option #define gcc_jit_context_set_logfile fn_gcc_jit_context_set_logfile +#define gcc_jit_context_set_str_option fn_gcc_jit_context_set_str_option #define gcc_jit_function_get_param fn_gcc_jit_function_get_param #define gcc_jit_function_new_block fn_gcc_jit_function_new_block #define gcc_jit_function_new_local fn_gcc_jit_function_new_local @@ -4364,6 +4370,30 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, comp.func_relocs_local = NULL; +#ifdef WINDOWSNT + /* Tell libgccjit the actual file name of the loaded DLL, otherwise + it will use 'libgccjit.so', which is not useful. */ + Lisp_Object libgccjit_loaded_from = Fget (Qgccjit, QCloaded_from); + Lisp_Object libgccjit_fname; + + if (CONSP (libgccjit_loaded_from)) + { + /* Use the absolute file name if available, otherwise the name + we looked for in w32_delayed_load. */ + libgccjit_fname = XCDR (libgccjit_loaded_from); + if (NILP (libgccjit_fname)) + libgccjit_fname = XCAR (libgccjit_loaded_from); + /* Must encode to ANSI, as libgccjit will not be able to handle + UTF-8 encoded file names. */ + libgccjit_fname = ansi_encode_filename (libgccjit_fname); + gcc_jit_context_set_str_option (comp.ctxt, GCC_JIT_STR_OPTION_PROGNAME, + SSDATA (libgccjit_fname)); + } + else /* this should never happen */ + gcc_jit_context_set_str_option (comp.ctxt, GCC_JIT_STR_OPTION_PROGNAME, + "libgccjit-0.dll"); +#endif + comp.speed = XFIXNUM (CALL1I (comp-ctxt-speed, Vcomp_ctxt)); eassert (comp.speed < INT_MAX); comp.debug = XFIXNUM (CALL1I (comp-ctxt-debug, Vcomp_ctxt)); commit c60f2f458a63a8ae4288652228f24e43fdc7bba7 Author: Andrea Corallo Date: Sat Mar 6 22:36:50 2021 +0100 Fix `comp-cstr-intersection-no-hashcons' for negated result cstr * lisp/emacs-lisp/comp-cstr.el (comp-cstr-intersection-no-hashcons): When negated and necessary relax dst to t. * test/src/comp-tests.el (comp-tests-type-spec-tests): Add a test. diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el index d6423efa0d..4397a91498 100644 --- a/lisp/emacs-lisp/comp-cstr.el +++ b/lisp/emacs-lisp/comp-cstr.el @@ -1001,20 +1001,26 @@ promoted to their types. DST is returned." (with-comp-cstr-accessors (apply #'comp-cstr-intersection dst srcs) - (let (strip-values strip-types) - (cl-loop for v in (valset dst) - unless (or (symbolp v) - (fixnump v)) - do (push v strip-values) - (push (type-of v) strip-types)) - (when strip-values - (setf (typeset dst) (comp-union-typesets (typeset dst) strip-types) - (valset dst) (cl-set-difference (valset dst) strip-values))) - (cl-loop for (l . h) in (range dst) - when (or (bignump l) (bignump h)) + (if (and (neg dst) + (valset dst) + (cl-notevery #'symbolp (valset dst))) + (setf (valset dst) () + (typeset dst) '(t) + (range dst) () + (neg dst) nil) + (let (strip-values strip-types) + (cl-loop for v in (valset dst) + unless (symbolp v) + do (push v strip-values) + (push (type-of v) strip-types)) + (when strip-values + (setf (typeset dst) (comp-union-typesets (typeset dst) strip-types) + (valset dst) (cl-set-difference (valset dst) strip-values))) + (cl-loop for (l . h) in (range dst) + when (or (bignump l) (bignump h)) do (setf (range dst) '((- . +))) - (cl-return)) - dst))) + (cl-return)))) + dst)) (defun comp-cstr-intersection-make (&rest srcs) "Combine SRCS by intersection set operation and return a new constraint." diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index cd1c2e0735..f60e4ab049 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -1340,7 +1340,14 @@ Return a list of results." (unless (eql x -0.0) (error "")) x) - float))) + float) + + ;; 73 + ((defun comp-tests-ret-type-spec-f (x) + (when (eql x 1.0) + (error "")) + x) + t))) (defun comp-tests-define-type-spec-test (number x) `(comp-deftest ,(intern (format "ret-type-spec-%d" number)) () commit 6c73418c95ae5aca7e63d8d5703a90e178350527 Author: Pip Cet Date: Sat Mar 6 20:53:57 2021 +0000 Fix miscompilation of funcall forms in some cases (bug#46974) * lisp/emacs-lisp/comp.el (comp-call-optim-func): Call comp-cstr-imm-vld-p before relying on comp-cstr-imm to return the right value. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 8a6e761fe4..134b5a2808 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -3282,11 +3282,13 @@ FUNCTION can be a function-name or byte compiled function." do (comp-loop-insn-in-block b (pcase insn (`(set ,lval (callref funcall ,f . ,rest)) - (when-let ((new-form (comp-call-optim-form-call + (when-let ((ok (comp-cstr-imm-vld-p f)) + (new-form (comp-call-optim-form-call (comp-cstr-imm f) rest))) (setf insn `(set ,lval ,new-form)))) (`(callref funcall ,f . ,rest) - (when-let ((new-form (comp-call-optim-form-call + (when-let ((ok (comp-cstr-imm-vld-p f)) + (new-form (comp-call-optim-form-call (comp-cstr-imm f) rest))) (setf insn new-form))))))) commit 3848f3bff0d39e21ee016ea9c3fae4bf07fc0a57 Author: Andrea Corallo Date: Sat Mar 6 20:51:11 2021 +0100 * lisp/emacs-lisp/comp.el (comp-add-cond-cstrs-simple): Suppress warning. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 4a418c1aad..8a6e761fe4 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2384,8 +2384,7 @@ TARGET-BB-SYM is the symbol name of the target block." for insn-seq on (comp-block-insns b) do (pcase insn-seq - (`((set ,(and (pred comp-mvar-p) tmp-mvar) - ,(and (pred comp-mvar-p) obj1)) + (`((set ,(and (pred comp-mvar-p) tmp-mvar) ,(pred comp-mvar-p)) ;; (comment ,_comment-str) (cond-jump ,tmp-mvar ,obj2 . ,blocks)) (cl-loop commit 05259c4a238efa40fa66ac51844aa5227b9c576b Author: Andrea Corallo Date: Sat Mar 6 20:38:00 2021 +0100 Fix `=' propagation to handle -0.0 0.0 case * lisp/emacs-lisp/comp-cstr.el (comp-cstr-intersection-homogeneous): Fix indent + use `memql'. (comp-cstr-=): Handle 0.0 -0.0 idiosyncrasy * test/src/comp-tests.el (comp-tests-type-spec-tests): Add two tests and fix enumeration. diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el index 6a8ec5213d..d6423efa0d 100644 --- a/lisp/emacs-lisp/comp-cstr.el +++ b/lisp/emacs-lisp/comp-cstr.el @@ -664,7 +664,7 @@ DST is returned." (cl-return-from comp-cstr-intersection-homogeneous dst)) (setf (neg dst) (when srcs - (neg (car srcs)))) + (neg (car srcs)))) ;; Type propagation. (setf (typeset dst) @@ -682,7 +682,7 @@ DST is returned." ;; If (member value) is subtypep of all other sources then ;; is good to be colleted. when (cl-every (lambda (s) - (or (memq val (valset s)) + (or (memql val (valset s)) (cl-some (lambda (type) (cl-typep val type)) (typeset s)))) @@ -890,6 +890,10 @@ Non memoized version of `comp-cstr-intersection-no-mem'." (cl-return cstr) finally (setf (valset cstr) (append vals-to-add (valset cstr)))) + (when (memql 0.0 (valset cstr)) + (cl-pushnew -0.0 (valset cstr))) + (when (memql -0.0 (valset cstr)) + (cl-pushnew 0.0 (valset cstr))) cstr)) (comp-cstr-intersection dst (relax-cstr op1) (relax-cstr op2))))) diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index dae2abca7e..cd1c2e0735 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -1299,32 +1299,48 @@ Return a list of results." (error ""))) cons) - ;; 69 + ;; 68 ((defun comp-tests-ret-type-spec-f (x) (if (and (floatp x) - (= x 0)) + (= x 1)) x (error ""))) ;; Conservative (see cstr relax in `comp-cstr-='). - (or (member 0.0) (integer 0 0))) + (or (member 1.0) (integer 1 1))) - ;; 70 + ;; 69 ((defun comp-tests-ret-type-spec-f (x) (if (and (integer x) - (= x 0)) + (= x 1)) x (error ""))) ;; Conservative (see cstr relax in `comp-cstr-='). - (or (member 0.0) (integer 0 0))) + (or (member 1.0) (integer 1 1))) - ;; 71 + ;; 70 ((defun comp-tests-ret-type-spec-f (x y) (if (and (floatp x) (integerp y) (= x y)) x (error ""))) - (or float integer)))) + (or float integer)) + + ;; 71 + ((defun comp-tests-ret-type-spec-f (x) + (if (= x 0.0) + x + (error ""))) + (or (member -0.0 0.0) (integer 0 0))) + + ;; 72 + ((defun comp-tests-ret-type-spec-f (x) + (unless (= x 0.0) + (error "")) + (unless (eql x -0.0) + (error "")) + x) + float))) (defun comp-tests-define-type-spec-test (number x) `(comp-deftest ,(intern (format "ret-type-spec-%d" number)) () commit 552ef6d6c0733b864bcb14eeb6183d7e64df3b80 Author: Eli Zaretskii Date: Fri Mar 5 16:39:10 2021 +0200 Fix some unsafe uses of SSDATA in comp.c * src/comp.c (comp_hash_source_file) (Fcomp__compile_ctxt_to_file, Fnative_elisp_load): Encode file names before passing them to library APIs. (Fcomp__compile_ctxt_to_file): use emacs_fopen instead of fopen. (declare_lex_function): Avoid keeping a 'char *' pointer around while calling Lisp, which could trigger GC, which could relocate string data. diff --git a/src/comp.c b/src/comp.c index 17dc4cbc13..94d3fa99a3 100644 --- a/src/comp.c +++ b/src/comp.c @@ -36,6 +36,7 @@ along with GNU Emacs. If not, see . */ #include "dynlib.h" #include "buffer.h" #include "blockinput.h" +#include "coding.h" #include "md5.h" #include "sysstdio.h" #include "zlib.h" @@ -693,7 +694,8 @@ comp_hash_source_file (Lisp_Object filename) /* Can't use Finsert_file_contents + Fbuffer_hash as this is called by Fcomp_el_to_eln_filename too early during bootstrap. */ bool is_gz = suffix_p (filename, ".gz"); - FILE *f = emacs_fopen (SSDATA (filename), is_gz ? "rb" : "r"); + Lisp_Object encoded_filename = ENCODE_FILE (filename); + FILE *f = emacs_fopen (SSDATA (encoded_filename), is_gz ? "rb" : "r"); if (!f) report_file_error ("Opening source file", filename); @@ -3792,7 +3794,7 @@ static gcc_jit_function * declare_lex_function (Lisp_Object func) { gcc_jit_function *res; - char *c_name = SSDATA (CALL1I (comp-func-c-name, func)); + Lisp_Object c_name = CALL1I (comp-func-c-name, func); Lisp_Object args = CALL1I (comp-func-l-args, func); bool nargs = !NILP (CALL1I (comp-nargs-p, args)); USE_SAFE_ALLOCA; @@ -3814,7 +3816,7 @@ declare_lex_function (Lisp_Object func) res = gcc_jit_context_new_function (comp.ctxt, NULL, GCC_JIT_FUNCTION_EXPORTED, comp.lisp_obj_type, - c_name, + SSDATA (c_name), max_args, params, 0); @@ -3835,7 +3837,8 @@ declare_lex_function (Lisp_Object func) NULL, GCC_JIT_FUNCTION_EXPORTED, comp.lisp_obj_type, - c_name, ARRAYELTS (params), params, 0); + SSDATA (c_name), + ARRAYELTS (params), params, 0); } SAFE_FREE (); return res; @@ -4332,6 +4335,10 @@ add_driver_options (void) if (!NILP (Fcomp_native_driver_options_effective_p ())) FOR_EACH_TAIL (options) gcc_jit_context_add_driver_option (comp.ctxt, + /* FIXME: Need to encode + this, but how? either + ENCODE_FILE or + ENCODE_SYSTEM. */ SSDATA (XCAR (options))); return; #endif @@ -4353,6 +4360,7 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, CHECK_STRING (filename); Lisp_Object base_name = Fsubstring (filename, Qnil, make_fixnum (-4)); + Lisp_Object ebase_name = ENCODE_FILE (base_name); comp.func_relocs_local = NULL; @@ -4367,7 +4375,7 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, 1); if (comp.debug > 2) { - logfile = fopen ("libgccjit.log", "w"); + logfile = emacs_fopen ("libgccjit.log", "w"); gcc_jit_context_set_logfile (comp.ctxt, logfile, 0, 0); @@ -4428,18 +4436,18 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, if (comp.debug) gcc_jit_context_dump_to_file (comp.ctxt, - format_string ("%s.c", SSDATA (base_name)), + format_string ("%s.c", SSDATA (ebase_name)), 1); if (!NILP (Fsymbol_value (Qcomp_libgccjit_reproducer))) gcc_jit_context_dump_reproducer_to_file ( comp.ctxt, - format_string ("%s_libgccjit_repro.c", SSDATA (base_name))); + format_string ("%s_libgccjit_repro.c", SSDATA (ebase_name))); Lisp_Object tmp_file = Fmake_temp_file_internal (base_name, Qnil, build_string (".eln.tmp"), Qnil); gcc_jit_context_compile_to_file (comp.ctxt, GCC_JIT_OUTPUT_KIND_DYNAMIC_LIBRARY, - SSDATA (tmp_file)); + SSDATA (ENCODE_FILE (tmp_file))); const char *err = gcc_jit_context_get_first_error (comp.ctxt); if (err) @@ -5043,28 +5051,29 @@ LATE_LOAD has to be non-nil when loading for deferred compilation. */) xsignal2 (Qnative_lisp_load_failed, build_string ("file does not exists"), filename); struct Lisp_Native_Comp_Unit *comp_u = allocate_native_comp_unit (); + Lisp_Object encoded_filename = ENCODE_FILE (filename); if (!NILP (Fgethash (filename, all_loaded_comp_units_h, Qnil)) && !file_in_eln_sys_dir (filename) && !NILP (Ffile_writable_p (filename))) { /* If in this session there was ever a file loaded with this - name rename before loading it to make sure we always get a + name, rename it before loading, to make sure we always get a new handle! */ Lisp_Object tmp_filename = Fmake_temp_file_internal (filename, Qnil, build_string (".eln.tmp"), Qnil); if (NILP (Ffile_writable_p (tmp_filename))) - comp_u->handle = dynlib_open (SSDATA (filename)); + comp_u->handle = dynlib_open (SSDATA (encoded_filename)); else { Frename_file (filename, tmp_filename, Qt); - comp_u->handle = dynlib_open (SSDATA (tmp_filename)); + comp_u->handle = dynlib_open (SSDATA (ENCODE_FILE (tmp_filename))); Frename_file (tmp_filename, filename, Qnil); } } else - comp_u->handle = dynlib_open (SSDATA (filename)); + comp_u->handle = dynlib_open (SSDATA (encoded_filename)); if (!comp_u->handle) xsignal2 (Qnative_lisp_load_failed, filename, commit 260617ddc2e8e46a741e6843f97c7ffbc5222ed0 Author: Andrea Corallo Date: Fri Mar 5 10:45:09 2021 +0100 * Harden `comp-abi-hash' computation Account for subr arity in `comp-abi-hash' computation as that's part of the ABI exposed to .eln files. * src/comp.c (Fcomp__subr_signature): New support function. (hash_native_abi): Make use of. (syms_of_comp): Register 'Scomp__subr_signature'. diff --git a/src/comp.c b/src/comp.c index 1e50b4fe8f..17dc4cbc13 100644 --- a/src/comp.c +++ b/src/comp.c @@ -713,6 +713,16 @@ comp_hash_source_file (Lisp_Object filename) return Fsubstring (digest, Qnil, make_fixnum (HASH_LENGTH)); } +DEFUN ("comp--subr-signature", Fcomp__subr_signature, + Scomp__subr_signature, 1, 1, 0, + doc: /* Support function to 'hash_native_abi'. +For internal use. */) + (Lisp_Object subr) +{ + return concat2 (Fsubr_name (subr), + Fprin1_to_string (Fsubr_arity (subr), Qnil)); +} + /* Produce a key hashing Vcomp_subr_list. */ void @@ -726,7 +736,7 @@ hash_native_abi (void) concat3 (build_string (ABI_VERSION), concat3 (Vemacs_version, Vsystem_configuration, Vsystem_configuration_options), - Fmapconcat (intern_c_string ("subr-name"), + Fmapconcat (intern_c_string ("comp--subr-signature"), Vcomp_subr_list, build_string ("")))); Vcomp_native_version_dir = concat3 (Vemacs_version, build_string ("-"), Vcomp_abi_hash); @@ -5199,6 +5209,7 @@ compiled one. */); build_pure_c_string ("eln file inconsistent with current runtime " "configuration, please recompile")); + defsubr (&Scomp__subr_signature); defsubr (&Scomp_el_to_eln_filename); defsubr (&Scomp_native_driver_options_effective_p); defsubr (&Scomp__install_trampoline); commit b9ccbac7685620d4624f55b9de361c610ede8aa4 Author: Andrea Corallo Date: Thu Mar 4 21:43:59 2021 +0100 * Makefile.in (ELN_DESTDIR): Remove unnecessary double quoting. diff --git a/Makefile.in b/Makefile.in index e3bbbec92a..691a955c54 100644 --- a/Makefile.in +++ b/Makefile.in @@ -336,7 +336,7 @@ CONFIG_STATUS_FILES_IN = \ COPYDIR = ${srcdir}/etc ${srcdir}/lisp COPYDESTS = "$(DESTDIR)${etcdir}" "$(DESTDIR)${lispdir}" -ELN_DESTDIR = "$(DESTDIR)${libdir}/emacs/${version}/" +ELN_DESTDIR = $(DESTDIR)${libdir}/emacs/${version}/ all: ${SUBDIR} info commit b456b19ec4e517cca53e4c6865059443300ae820 Author: Eli Zaretskii Date: Thu Mar 4 20:36:43 2021 +0200 Fix typos and doc strings in native-compilation files * lisp/emacs-lisp/comp.el (comp-speed, comp-debug, comp-verbose) (comp-always-compile, comp-deferred-compilation-deny-list) (comp-bootstrap-deny-list, comp-never-optimize-functions) (comp-async-jobs-number, comp-async-cu-done-hook) (comp-async-all-done-hook, comp-async-env-modifier-form) (comp-pass, comp-native-compiling, comp-post-pass-hooks) (comp-known-predicate-p, comp-pred-to-cstr) (comp-symbol-values-optimizable, comp-limple-assignments) (comp-limple-calls, comp-limple-branches, comp-block) (comp-vec--verify-idx, comp-vec-aref, comp-vec-append) (comp-vec-prepend, comp-block-preds) (comp-ensure-native-compiler, comp-log, comp-log-func) (comp-loop-insn-in-block, comp-byte-frame-size) (comp-add-func-to-ctxt, comp-spill-lap-function, comp-spill-lap) (comp-lap-fall-through-p, comp-new-frame, comp-emit-set-call) (comp-copy-slot, comp-latch-make-fill, comp-emit-cond-jump) (comp-body-eff, comp-op-case, comp-prepare-args-for-top-level) (comp-limplify-top-level, comp-negate-arithm-cmp-fun) (comp-emit-assume, comp-cond-cstrs-target-mvar) (comp-function-foldable-p, comp-function-call-maybe-fold) (comp-form-tco-call-seq, comp-clean-up-stale-eln) (comp-delete-or-replace-file, comp--native-compile) (native--compile-async, native-compile) (batch-byte-native-compile-for-bootstrap): Fix typos, wording, and punctuation in doc strings. * lisp/loadup.el: Fix typos. * src/lread.c (syms_of_lread): Doc fix. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index af14afd42b..4a418c1aad 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -45,56 +45,57 @@ :group 'lisp) (defcustom comp-speed 2 - "Compiler optimization level. From -1 to 3. -- -1 functions are kept in bytecode form and no native compilation is performed. -- 0 native compilation is performed with no optimizations. -- 1 lite optimizations. -- 2 max optimization level fully adherent to the language semantic. -- 3 max optimization level, to be used only when necessary. - Warning: the compiler is free to perform dangerous optimizations." + "Optimization level for native compilation, a number between -1 and 3. + -1 functions are kept in bytecode form and no native compilation is performed. + 0 native compilation is performed with no optimizations. + 1 light optimizations. + 2 max optimization level fully adherent to the language semantic. + 3 max optimization level, to be used only when necessary. + Warning: with 3, the compiler is free to perform dangerous optimizations." :type 'integer :safe #'integerp :version "28.1") (defcustom comp-debug 0 - "Compiler debug level. From 0 to 3. -This intended for debugging the compiler itself. -- 0 no debug facility. + "Debug level for native compilation, a number between 0 and 3. +This is intended for debugging the compiler itself. + 0 no debugging output. This is the recommended value unless you are debugging the compiler itself. -- 1 emit debug symbols and dump pseudo C code. -- 2 dump gcc passes and libgccjit log file. -- 3 dump libgccjit reproducers." + 1 emit debug symbols and dump pseudo C code. + 2 dump gcc passes and libgccjit log file. + 3 dump libgccjit reproducers." :type 'integer :safe #'natnump :version "28.1") (defcustom comp-verbose 0 - "Compiler verbosity. From 0 to 3. -This intended for debugging the compiler itself. -- 0 no logging. -- 1 final limple is logged. -- 2 LAP and final limple and some pass info are logged. -- 3 max verbosity." + "Compiler verbosity for native compilation, a number between 0 and 3. +This is intended for debugging the compiler itself. + 0 no logging. + 1 final LIMPLE is logged. + 2 LAP, final LIMPLE, and some pass info are logged. + 3 max verbosity." :type 'integer :risky t :version "28.1") (defcustom comp-always-compile nil - "Unconditionally (re-)compile all files." + "Non-nil means unconditionally (re-)compile all files." :type 'boolean :version "28.1") (defcustom comp-deferred-compilation-deny-list '() - "List of regexps to exclude files from deferred native compilation. -Skip if any is matching." + "List of regexps to exclude matching files from deferred native compilation. +Files whose names match any regexp is excluded from native compilation." :type 'list :version "28.1") (defcustom comp-bootstrap-deny-list '() "List of regexps to exclude files from native compilation during bootstrap. -Skip if any is matching." +Files whose names match any regexp is excluded from native compilation +during bootstrap." :type 'list :version "28.1") @@ -103,13 +104,14 @@ Skip if any is matching." ;; correctly (see comment in `advice--add-function'). DO NOT ;; REMOVE. macroexpand rename-buffer) - "Primitive functions for which we do not perform trampoline optimization." + "Primitive functions to exclude from trampoline optimization." :type 'list :version "28.1") (defcustom comp-async-jobs-number 0 - "Default number of processes used for async compilation. -When zero use half of the CPUs or at least one." + "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 :risky t :version "28.1") @@ -118,19 +120,18 @@ When zero use half of the CPUs or at least one." ;; like `comp-async-cu-done-function'. (defcustom comp-async-cu-done-hook nil "Hook run after asynchronously compiling a single compilation unit. -The argument FILE passed to the function is the filename used as -compilation input." +Called with one argument FILE, the filename used as input to compilation." :type 'hook :version "28.1") (defcustom comp-async-all-done-hook nil - "Hook run after asynchronously compiling all input files." + "Hook run after completing asynchronous compilation of all input files." :type 'hook :version "28.1") (defcustom comp-async-env-modifier-form nil - "Form evaluated before compilation by each asynchronous compilation worker. -Usable to modify the compiler environment." + "Form evaluated before compilation by each asynchronous compilation subprocess. +Used to modify the compiler environment." :type 'list :risky t :version "28.1") @@ -195,11 +196,12 @@ the .eln output directory." "Name of the async compilation buffer log.") (defvar comp-native-compiling nil - "This gets bound to t while native compilation. -Can be used by code that wants to expand differently in this case.") + "This gets bound to t during native compilation. +Intended to be used by code that needs to work differently when +native compilation runs.") (defvar comp-pass nil - "Every pass has the right to bind what it likes here.") + "Every native-compilation pass can bind this to whatever it likes.") (defvar comp-curr-allocation-class 'd-default "Current allocation class. @@ -223,7 +225,7 @@ Can be one of: 'd-default', 'd-impure' or 'd-ephemeral'. See `comp-ctxt'.") For internal use only by the testsuite.") (defvar comp-post-pass-hooks '() - "Alist PASS FUNCTIONS. + "Alist whose elements are of the form (PASS FUNCTIONS...). Each function in FUNCTIONS is run after PASS. Useful to hook into pass checkers.") @@ -583,16 +585,16 @@ Useful to hook into pass checkers.") "Hash table function -> `comp-constraint'") (defun comp-known-predicate-p (predicate) - "Predicate matching if PREDICATE is known." + "Return t if PREDICATE is known." (when (gethash predicate comp-known-predicates-h) t)) (defun comp-pred-to-cstr (predicate) - "Given PREDICATE return the correspondig constraint." + "Given PREDICATE, return the correspondig constraint." (gethash predicate comp-known-predicates-h)) (defconst comp-symbol-values-optimizable '(most-positive-fixnum most-negative-fixnum) - "Symbol values we can resolve in the compile-time.") + "Symbol values we can resolve at compile-time.") (defconst comp-type-hints '(comp-hint-fixnum comp-hint-cons) @@ -608,16 +610,16 @@ Useful to hook into pass checkers.") (defconst comp-limple-assignments `(assume fetch-handler ,@comp-limple-sets) - "Limple operators that clobbers the first m-var argument.") + "Limple operators that clobber the first m-var argument.") (defconst comp-limple-calls '(call callref direct-call direct-callref) - "Limple operators use to call subrs.") + "Limple operators used to call subrs.") (defconst comp-limple-branches '(jump cond-jump) - "Limple operators use for conditional and unconditional branches.") + "Limple operators used for conditional and unconditional branches.") (defconst comp-limple-ops `(,@comp-limple-calls ,@comp-limple-assignments @@ -629,7 +631,7 @@ Useful to hook into pass checkers.") "Bound to the current function by most passes.") (defvar comp-block nil - "Bound to the current basic block by some pass.") + "Bound to the current basic block by some passes.") (define-error 'native-compiler-error-dyn-func "can't native compile a non-lexically-scoped function" @@ -657,12 +659,12 @@ Useful to hook into pass checkers.") (- (comp-vec-end vec) (comp-vec-beg vec))) (defsubst comp-vec--verify-idx (vec idx) - "Check idx is in bounds for VEC." + "Check whether idx is in bounds for VEC." (cl-assert (and (< idx (comp-vec-end vec)) (>= idx (comp-vec-beg vec))))) (defsubst comp-vec-aref (vec idx) - "Return the element of VEC at index IDX." + "Return the element of VEC whose index is IDX." (declare (gv-setter (lambda (val) `(comp-vec--verify-idx ,vec ,idx) `(puthash ,idx ,val (comp-vec-data ,vec))))) @@ -671,14 +673,14 @@ Useful to hook into pass checkers.") (defsubst comp-vec-append (vec elt) "Append ELT into VEC. -ELT is returned." +Returns ELT." (puthash (comp-vec-end vec) elt (comp-vec-data vec)) (cl-incf (comp-vec-end vec)) elt) (defsubst comp-vec-prepend (vec elt) "Prepend ELT into VEC. -ELT is returned." +Returns ELT." (puthash (1- (comp-vec-beg vec)) elt (comp-vec-data vec)) (cl-decf (comp-vec-beg vec)) elt) @@ -818,7 +820,7 @@ non local exit (ends with an `unreachable' insn).")) (comp-func-edges-h comp-func)))) (defun comp-block-preds (basic-block) - "Given BASIC-BLOCK return the list of its predecessors." + "Return the list of predecessors of BASIC-BLOCK." (mapcar #'comp-edge-src (comp-block-in-edges basic-block))) (defun comp-gen-counter () @@ -895,14 +897,14 @@ In use by the backend." (defun comp-ensure-native-compiler () - "Make sure Emacs has native compiler support and libgccjit is loadable. + "Make sure Emacs has native compiler support and libgccjit can be loaded. Signal an error otherwise. To be used by all entry points." (cond ((null (featurep 'nativecomp)) - (error "Emacs not compiled with native compiler support (--with-nativecomp)")) + (error "Emacs was not compiled with native compiler support (--with-native-compilation)")) ((null (native-comp-available-p)) - (error "Cannot find libgccjit")))) + (error "Cannot find libgccjit library")))) (defun comp-equality-fun-p (function) "Equality functions predicate for FUNCTION." @@ -997,9 +999,9 @@ Assume allocation class 'd-default as default." (cl-defun comp-log (data &optional (level 1) quoted) "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'." +LEVEL is a number from 1-3, and defaults to 1; 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 (cl-typecase data @@ -1050,7 +1052,7 @@ log with `comp-log-to-buffer'." (cons (concat "(" (mapconcat #'comp-prettyformat-insn insn " ") ")")))) (defun comp-log-func (func verbosity) - "Log function FUNC. + "Log function FUNC at VERBOSITY. VERBOSITY is a number between 0 and 3." (when (>= comp-verbose verbosity) (comp-log (format "\nFunction: %s\n" (comp-func-name func)) verbosity) @@ -1080,7 +1082,7 @@ VERBOSITY is a number between 0 and 3." (defmacro comp-loop-insn-in-block (basic-block &rest body) "Loop over all insns in BASIC-BLOCK executing BODY. -Inside BODY `insn' and `insn-cell'can be used to read or set the +Inside BODY, `insn' and `insn-cell'can be used to read or set the current instruction or its cell." (declare (debug (form body)) (indent defun)) @@ -1157,11 +1159,11 @@ clashes." :rest rest)))) (defsubst comp-byte-frame-size (byte-compiled-func) - "Given BYTE-COMPILED-FUNC return the frame size to be allocated." + "Return the frame size to be allocated for BYTE-COMPILED-FUNC." (aref byte-compiled-func 3)) (defun comp-add-func-to-ctxt (func) - "Add FUNC to the current compiler contex." + "Add FUNC to the current compiler context." (let ((name (comp-func-name func)) (c-name (comp-func-c-name func))) (puthash name c-name (comp-ctxt-sym-to-c-name-h comp-ctxt)) @@ -1171,7 +1173,7 @@ clashes." "Byte-compile INPUT and spill lap for further stages.") (cl-defmethod comp-spill-lap-function ((function-name symbol)) - "Byte-compile FUNCTION-NAME spilling data from the byte compiler." + "Byte-compile FUNCTION-NAME, spilling data from the byte compiler." (unless (comp-ctxt-output comp-ctxt) (setf (comp-ctxt-output comp-ctxt) (make-temp-file (comp-c-func-name function-name "freefn-") @@ -1208,10 +1210,10 @@ clashes." (comp-add-func-to-ctxt func)))) (cl-defmethod comp-spill-lap-function ((form list)) - "Byte-compile FORM spilling data from the byte compiler." + "Byte-compile FORM, spilling data from the byte compiler." (unless (eq (car-safe form) 'lambda) (signal 'native-compiler-error - "Cannot native compile, form is not a lambda")) + "Cannot native-compile, form is not a lambda")) (unless (comp-ctxt-output comp-ctxt) (setf (comp-ctxt-output comp-ctxt) (make-temp-file "comp-lambda-" nil ".eln"))) @@ -1283,7 +1285,7 @@ clashes." (comp-log lap 1 t)))) (cl-defmethod comp-spill-lap-function ((filename string)) - "Byte-compile FILENAME spilling data from the byte compiler." + "Byte-compile FILENAME, spilling data from the byte compiler." (byte-compile-file filename) (unless byte-to-native-top-level-forms (signal 'native-compiler-error-empty-byte filename)) @@ -1316,8 +1318,8 @@ clashes." (defun comp-spill-lap (input) "Byte-compile and spill the LAP representation for INPUT. -If INPUT is a symbol this is the function-name to be compiled. -If INPUT is a string this is the filename to be compiled." +If INPUT is a symbol, it is the function-name to be compiled. +If INPUT is a string, it is the filename to be compiled." (let ((byte-native-compiling t) (byte-to-native-lambdas-h (make-hash-table :test #'eq)) (byte-to-native-top-level-forms ()) @@ -1355,7 +1357,7 @@ Points to the next slot to be filled.") t)) (defun comp-lap-fall-through-p (inst) - "Return t if INST fall through, nil otherwise." + "Return t if INST falls through, nil otherwise." (when (not (memq (car inst) '(byte-goto byte-return))) t)) @@ -1442,7 +1444,7 @@ STACK-OFF is the index of the first slot frame involved." (defun comp-new-frame (size vsize &optional ssa) "Return a clean frame of meta variables of size SIZE and VSIZE. -If SSA non-nil populate it of m-var in ssa form." +If SSA is non-nil, populate it with m-var in ssa form." (cl-loop with v = (make-comp-vec :beg (- vsize) :end size) for i from (- vsize) below size for mvar = (if ssa @@ -1459,13 +1461,13 @@ If SSA non-nil populate it of m-var in ssa form." (defun comp-emit-set-call (call) "Emit CALL assigning the result the the current slot frame. -If the callee function is known to have a return type propagate it." +If the callee function is known to have a return type, propagate it." (cl-assert call) (comp-emit (list 'set (comp-slot) call))) (defun comp-copy-slot (src-n &optional dst-n) "Set slot number DST-N to slot number SRC-N as source. -If DST-N is specified use it otherwise assume it to be the current slot." +If DST-N is specified, use it; otherwise assume it to be the current slot." (comp-with-sp (or dst-n (comp-sp)) (let ((src-slot (comp-slot-n src-n))) (cl-assert src-slot) @@ -1496,7 +1498,7 @@ Add block to the current function and return it." (defun comp-latch-make-fill (target) "Create a latch pointing to TARGET and fill it. -Return the created latch" +Return the created latch." (let ((latch (make-comp-latch :name (comp-new-block-sym "latch"))) (curr-bb (comp-limplify-curr-block comp-pass))) ;; See `comp-make-curr-block'. @@ -1530,8 +1532,8 @@ Return the created latch" "Emit a conditional jump to LAP-LABEL when A and B satisfy EQ. TARGET-OFFSET is the positive offset on the SP when branching to the target block. -If NEGATED non null negate the tested condition. -Return value is the fall through block name." +If NEGATED is non null, negate the tested condition. +Return value is the fall-through block name." (cl-destructuring-bind (label-num . label-sp) lap-label (let* ((bb (comp-block-name (comp-bb-maybe-add (1+ (comp-limplify-pc comp-pass)) @@ -1682,8 +1684,8 @@ SP-DELTA is the stack adjustment." (intern (replace-regexp-in-string "byte-" "" x))) (defun comp-body-eff (body op-name sp-delta) - "Given the original body BODY compute the effective one. -When BODY is auto guess function name form the LAP byte-code + "Given the original BODY, compute the effective one. +When BODY is `auto', guess function name from the LAP byte-code name. Otherwise expect lname fnname." (pcase (car body) ('auto @@ -1694,8 +1696,8 @@ name. Otherwise expect lname fnname." (defmacro comp-op-case (&rest cases) "Expand CASES into the corresponding `pcase' expansion. -This is responsible for generating the proper stack adjustment when known and -the annotation emission." +This is responsible for generating the proper stack adjustment, when known, +and the annotation emission." (declare (debug (body)) (indent defun)) `(pcase op @@ -1963,7 +1965,7 @@ the annotation emission." func) (cl-defgeneric comp-prepare-args-for-top-level (function) - "Given FUNCTION, return the two args arguments for comp--register-...") + "Given FUNCTION, return the two arguments for comp--register-...") (cl-defmethod comp-prepare-args-for-top-level ((function comp-func-l)) "Lexically-scoped FUNCTION." @@ -1974,7 +1976,7 @@ the annotation emission." 'many))))) (cl-defmethod comp-prepare-args-for-top-level ((function comp-func-d)) - "Dynamic scoped FUNCTION." + "Dynamically scoped FUNCTION." (cons (make-comp-mvar :constant (func-arity (comp-func-byte-func function))) (let ((comp-curr-allocation-class 'd-default)) ;; Lambda-lists must stay in the same relocation class of @@ -2060,15 +2062,15 @@ These are stored in the reloc data array." (defun comp-limplify-top-level (for-late-load) "Create a limple function to modify the global environment at load. -When FOR-LATE-LOAD is non-nil the emitted function modifies only +When FOR-LATE-LOAD is non-nil, the emitted function modifies only function definition. -Synthesize a function called 'top_level_run' that gets one single -parameter (the compilation unit it-self). To define native -functions 'top_level_run' will call back `comp--register-subr' +Synthesize a function called `top_level_run' that gets one single +parameter (the compilation unit itself). To define native +functions, `top_level_run' will call back `comp--register-subr' into the C code forwarding the compilation unit." ;; Once an .eln is loaded and Emacs is dumped 'top_level_run' has no - ;; reasons to be execute ever again. Therefore all objects can be + ;; reasons to be executed ever again. Therefore all objects can be ;; just ephemeral. (let* ((comp-curr-allocation-class 'd-ephemeral) (func (make-comp-func-l :name (if for-late-load @@ -2240,8 +2242,7 @@ into the C code forwarding the compilation unit." (defun comp-negate-arithm-cmp-fun (function) "Negate FUNCTION. -Return nil if we don't want to emit constraints for its -negation." +Return nil if we don't want to emit constraints for its negation." (cl-ecase function (= nil) (> '<=) @@ -2261,7 +2262,7 @@ negation." (defun comp-emit-assume (kind lhs rhs bb negated) "Emit an assume of kind KIND for mvar LHS being RHS. -When NEGATED is non-nil the assumption is negated. +When NEGATED is non-nil, the assumption is negated. The assume is emitted at the beginning of the block BB." (let ((lhs-slot (comp-mvar-slot lhs))) (cl-assert lhs-slot) @@ -2335,7 +2336,7 @@ Return OP otherwise." ;; Cheap substitute to a copy propagation pass... (defun comp-cond-cstrs-target-mvar (mvar exit-insn bb) - "Given MVAR search in BB the original mvar MVAR got assigned from. + "Given MVAR, search in BB the original mvar MVAR got assigned from. Keep on searching till EXIT-INSN is encountered." (cl-flet ((targetp (x) ;; Ret t if x is an mvar and target the correct slot number. @@ -3029,12 +3030,12 @@ Forward propagate immediate involed in assignments." (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." + "Given function F called with ARGS, return non-nil when optimizable." (and (comp-function-pure-p f) (cl-every #'comp-cstr-imm-vld-p args))) (defun comp-function-call-maybe-fold (insn f args) - "Given INSN when F is pure if all ARGS are known remove the function call. + "Given INSN, when F is pure if all ARGS are known, remove the function call. Return non-nil if the function is folded successfully." (cl-flet ((rewrite-insn-as-setimm (insn value) ;; See `comp-emit-setimm'. @@ -3372,7 +3373,7 @@ Return the list of m-var ids nuked." ;;; Tail Call Optimization pass specific code. (defun comp-form-tco-call-seq (args) - "Generate a tco sequence for ARGS." + "Generate a TCO sequence for ARGS." `(,@(cl-loop for arg in args for i from 0 collect `(set ,(make-comp-mvar :slot i) ,arg)) @@ -3747,7 +3748,7 @@ Return the trampoline if found or nil otherwise." ;;;###autoload (defun comp-clean-up-stale-eln (file) - "Given FILE remove all the .eln files in `comp-eln-load-path' + "Given FILE remove all its *.eln files in `comp-eln-load-path' sharing the original source filename (including FILE)." (when (string-match (rx "-" (group-n 1 (1+ hex)) "-" (1+ hex) ".eln" eos) file) @@ -3765,7 +3766,7 @@ sharing the original source filename (including FILE)." "Replace OLDFILE with NEWFILE. When NEWFILE is nil just delete OLDFILE. Takes the necessary steps when dealing with OLDFILE being a -shared libraries that may be currently loaded by a running Emacs +shared library that might be currently loaded into a running Emacs session." (cond ((eq 'windows-nt system-type) (ignore-errors (delete-file oldfile)) @@ -3929,8 +3930,8 @@ display a message." (defun comp--native-compile (function-or-file &optional with-late-load output) "Compile FUNCTION-OR-FILE into native code. This serves as internal implementation of `native-compile'. -When WITH-LATE-LOAD non-nil mark the compilation unit for late -load once finished compiling." +When WITH-LATE-LOAD is non-nil, mark the compilation unit for late +load once it finishes compiling." (comp-ensure-native-compiler) (unless (or (functionp function-or-file) (stringp function-or-file)) @@ -3975,7 +3976,7 @@ load once finished compiling." (native-elisp-load data)))) (defun native-compile-async-skip-p (file load selector) - "Return non-nil when FILE compilation should be skipped. + "Return non-nil if FILE's compilation should be skipped. LOAD and SELECTOR work as described in `native--compile-async'." ;; Make sure we are not already compiling `file' (bug#40838). @@ -4014,13 +4015,13 @@ of (commands) to run simultaneously. LOAD can also be the symbol `late'. This is used internally if the byte code has already been loaded when this function is -called. It means that we requests the special kind of load, +called. It means that we request the special kind of load necessary in that situation, called \"late\" loading. -During a \"late\" load instead of executing all top level forms +During a \"late\" load, instead of executing all top-level forms of the original files, only function definitions are loaded (paying attention to have these effective only if the -bytecode definition was not changed in the meanwhile)." +bytecode definition was not changed in the meantime)." (comp-ensure-native-compiler) (unless (member load '(nil t late)) (error "LOAD must be nil, t or 'late")) @@ -4068,13 +4069,13 @@ bytecode definition was not changed in the meanwhile)." "Compile FUNCTION-OR-FILE into native code. This is the synchronous entry-point for the Emacs Lisp native compiler. -FUNCTION-OR-FILE is a function symbol, a form or the filename of +FUNCTION-OR-FILE is a function symbol, a form, or the filename of an Emacs Lisp source file. -When OUTPUT is non-nil use it as filename for the compiled +If OUTPUT is non-nil, use it as the filename for the compiled object. -If FUNCTION-OR-FILE is a filename return the filename of the +If FUNCTION-OR-FILE is a filename, return the filename of the compiled object. If FUNCTION-OR-FILE is a function symbol or a -form return the compiled function." +form, return the compiled function." (comp--native-compile function-or-file nil output)) ;;;###autoload @@ -4092,9 +4093,9 @@ Ultra cheap impersonation of `batch-byte-compile'." ;;;###autoload (defun batch-byte-native-compile-for-bootstrap () - "As `batch-byte-compile' but used for booststrap. -Generate .elc files in addition to the .eln one. If the -environment variable 'NATIVE_DISABLED' is set byte compile only." + "Like `batch-native-compile', but used for booststrap. +Generate *.elc files in addition to the *.eln files. If the +environment variable 'NATIVE_DISABLED' is set, only byte compile." (comp-ensure-native-compiler) (if (equal (getenv "NATIVE_DISABLED") "1") (batch-byte-compile) diff --git a/lisp/loadup.el b/lisp/loadup.el index 526f7c3328..98d4e4fe67 100644 --- a/lisp/loadup.el +++ b/lisp/loadup.el @@ -450,8 +450,9 @@ lost after dumping"))) (when (featurep 'nativecomp) ;; Fix the compilation unit filename to have it working when - ;; when installed or if the source directory got moved. This is set to be - ;; a pair in the form: (rel-path-from-install-bin . rel-path-from-local-bin). + ;; installed or if the source directory got moved. This is set to be + ;; a cons cell of the form: + ;; (rel-filename-from-install-bin . rel-filename-from-local-bin). (let ((h (make-hash-table :test #'eq)) (bin-dest-dir (cadr (member "--bin-dest" command-line-args))) (eln-dest-dir (cadr (member "--eln-dest" command-line-args)))) @@ -466,12 +467,12 @@ lost after dumping"))) (native-comp-unit-set-file cu (cons - ;; Relative path from the installed binary. + ;; Relative filename from the installed binary. (file-relative-name (concat eln-dest-dir (file-name-nondirectory (native-comp-unit-file cu))) bin-dest-dir) - ;; Relative path from the built uninstalled binary. + ;; Relative filename from the built uninstalled binary. (file-relative-name (native-comp-unit-file cu) invocation-directory)))) h)))) @@ -536,8 +537,8 @@ lost after dumping"))) (t (error "unrecognized dump mode %s" dump-mode))))) (when (and (featurep 'nativecomp) (equal dump-mode "pdump")) - ;; Don't enable this before bootstrap is completed the as the - ;; compiler infrastructure may not be usable. + ;; Don't enable this before bootstrap is completed, as the + ;; compiler infrastructure may not be usable yet. (setq comp-enable-subr-trampolines t)) (message "Dumping under the name %s" output) (condition-case () diff --git a/src/lread.c b/src/lread.c index d947c4e519..989b55c88f 100644 --- a/src/lread.c +++ b/src/lread.c @@ -5200,8 +5200,7 @@ that are loaded before your customizations are read! */); load_prefer_newer = 0; DEFVAR_BOOL ("load-no-native", load_no_native, - doc: /* Do not try to load the a .eln file in place of - a .elc one. */); + doc: /* Non-nil means not to load a .eln file when a .elc was requested. */); load_no_native = false; /* Vsource_directory was initialized in init_lread. */ commit 6444f69de277454491367b74434ac6d9fd122f50 Author: Andrea Corallo Date: Thu Mar 4 09:03:26 2021 +0100 * src/comp.c (hash_native_abi): Account for `system-configuraton-options'. diff --git a/src/comp.c b/src/comp.c index bc45859533..1e50b4fe8f 100644 --- a/src/comp.c +++ b/src/comp.c @@ -724,7 +724,8 @@ hash_native_abi (void) Vcomp_abi_hash = comp_hash_string ( concat3 (build_string (ABI_VERSION), - concat2 (Vemacs_version, Vsystem_configuration), + concat3 (Vemacs_version, Vsystem_configuration, + Vsystem_configuration_options), Fmapconcat (intern_c_string ("subr-name"), Vcomp_subr_list, build_string ("")))); Vcomp_native_version_dir = commit 43b40bc880f66cb3f48318ba3a480a76b149b815 Author: Pip Cet Date: Sun Feb 28 06:31:00 2021 +0000 Don't call _setjmp through a function pointer (Bug#46824) * src/comp.c (helper_link_table): Don't include SETJMP except on Windows. (emit_setjmp): Don't use function pointers except on Windows. (declare_runtime_imported_funcs): Don't import SETJMP at runtime. (ABI_VERSION): Bump. * test/src/comp-tests.el (46824-1): New test. * test/src/comp-test-funcs.el (comp-test-46824-1-f): New function. diff --git a/src/comp.c b/src/comp.c index bcffd426d9..bc45859533 100644 --- a/src/comp.c +++ b/src/comp.c @@ -422,7 +422,7 @@ load_gccjit_if_necessary (bool mandatory) /* Increase this number to force a new Vcomp_abi_hash to be generated. */ -#define ABI_VERSION "1" +#define ABI_VERSION "2" /* Length of the hashes used for eln file naming. */ #define HASH_LENGTH 8 @@ -646,7 +646,9 @@ void *helper_link_table[] = helper_PSEUDOVECTOR_TYPEP_XUNTAG, pure_write_error, push_handler, +#ifdef WINDOWSNT SETJMP_NAME, +#endif record_unwind_protect_excursion, helper_unbind_n, helper_save_restriction, @@ -1935,8 +1937,19 @@ emit_setjmp (gcc_jit_rvalue *buf) { #ifndef WINDOWSNT gcc_jit_rvalue *args[] = {buf}; - return emit_call (intern_c_string (STR (SETJMP_NAME)), comp.int_type, 1, args, - false); + gcc_jit_param *params[] = + { + gcc_jit_context_new_param (comp.ctxt, NULL, comp.void_ptr_type, "buf"), + }; + /* Don't call setjmp through a function pointer (Bug#46824) */ + gcc_jit_function *f = + gcc_jit_context_new_function (comp.ctxt, NULL, + GCC_JIT_FUNCTION_IMPORTED, + comp.int_type, STR (SETJMP_NAME), + ARRAYELTS (params), params, + false); + + return gcc_jit_context_new_call (comp.ctxt, NULL, f, 1, args); #else /* _setjmp (buf, __builtin_frame_address (0)) */ gcc_jit_rvalue *args[2]; @@ -2668,10 +2681,7 @@ declare_runtime_imported_funcs (void) args[1] = comp.int_type; ADD_IMPORTED (push_handler, comp.handler_ptr_type, 2, args); -#ifndef WINDOWSNT - args[0] = gcc_jit_type_get_pointer (gcc_jit_struct_as_type (comp.jmp_buf_s)); - ADD_IMPORTED (SETJMP_NAME, comp.int_type, 1, args); -#else +#ifdef WINDOWSNT args[0] = gcc_jit_type_get_pointer (gcc_jit_struct_as_type (comp.jmp_buf_s)); args[1] = comp.void_ptr_type; ADD_IMPORTED (SETJMP_NAME, comp.int_type, 2, args); diff --git a/test/src/comp-test-funcs.el b/test/src/comp-test-funcs.el index a465026fb3..08aa6bb472 100644 --- a/test/src/comp-test-funcs.el +++ b/test/src/comp-test-funcs.el @@ -1,6 +1,6 @@ ;;; comp-test-funcs.el --- compilation unit tested by comp-tests.el -*- lexical-binding: t; -*- -;; Copyright (C) 2019-2020 Free Software Foundation, Inc. +;; Copyright (C) 2019-2021 Free Software Foundation, Inc. ;; Author: Andrea Corallo @@ -485,6 +485,22 @@ (and (equal (comp-test-46670-1-f (length s)) s) s)) +(cl-defun comp-test-46824-1-f () + (let ((next-repos '(1))) + (while t + (let ((recipe (car next-repos))) + (cl-block loop + (while t + (let ((err + (condition-case e + (progn + (setq next-repos + (cdr next-repos)) + (cl-return-from loop)) + (error e)))) + (format "%S" + (error-message-string err)))))) + (cl-return-from comp-test-46824-1-f)))) ;;;;;;;;;;;;;;;;;;;; ;; Tromey's tests ;; diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 3f007d2a59..dae2abca7e 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -1,6 +1,6 @@ ;;; comp-tests.el --- unit tests for src/comp.c -*- lexical-binding: t; -*- -;; Copyright (C) 2019-2020 Free Software Foundation, Inc. +;; Copyright (C) 2019-2021 Free Software Foundation, Inc. ;; Author: Andrea Corallo @@ -503,6 +503,10 @@ https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-03/msg00914.html." (should (equal (subr-type (symbol-function #'comp-test-46670-2-f)) '(function (t) (or null sequence))))) +(comp-deftest 46824-1 () + "" + (should (equal (comp-test-46824-1-f) nil))) + ;;;;;;;;;;;;;;;;;;;;; ;; Tromey's tests. ;; commit cf37850e2d69eda908495950acf8decb0ecec517 Author: Andrea Corallo Date: Wed Mar 3 20:25:14 2021 +0100 * src/comp.c (return_nil): Make it not a nested function. diff --git a/src/comp.c b/src/comp.c index d74f8328fd..bcffd426d9 100644 --- a/src/comp.c +++ b/src/comp.c @@ -4506,6 +4506,14 @@ helper_PSEUDOVECTOR_TYPEP_XUNTAG (Lisp_Object a, enum pvec_type code) static Lisp_Object all_loaded_comp_units_h; +#ifdef WINDOWSNT +static Lisp_Object +return_nil (Lisp_Object arg) +{ + return Qnil; +} +#endif + /* Windows does not let us delete a .eln file that is currently loaded by a process. The strategy is to rename .eln files into .old.eln instead of removing them when this is not possible and clean-up @@ -4517,8 +4525,6 @@ void eln_load_path_final_clean_up (void) { #ifdef WINDOWSNT - Lisp_Object return_nil (Lisp_Object arg) { return Qnil; } - Lisp_Object dir_tail = Vcomp_eln_load_path; FOR_EACH_TAIL (dir_tail) { commit 0c5ba41b72a19f5353083431a1817d86bc3b7fad Author: Andrea Corallo Date: Tue Mar 2 17:23:12 2021 +0100 Fix two compiler ICEs dealing with nan and infinity * lisp/emacs-lisp/comp-cstr.el (comp-cstr-=): Don't crash when truncate fails. * test/src/comp-test-funcs.el (comp-test-=-nan): Add two functions to be compiled. diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el index 996502b286..6a8ec5213d 100644 --- a/lisp/emacs-lisp/comp-cstr.el +++ b/lisp/emacs-lisp/comp-cstr.el @@ -871,9 +871,12 @@ Non memoized version of `comp-cstr-intersection-no-mem'." ;; precisely as an integer add the integer as well. (cl-loop for v in (valset cstr) - when (and (floatp v) - (= v (truncate v))) - do (push (cons (truncate v) (truncate v)) (range cstr))) + do + (when-let* ((ok (floatp v)) + (truncated (ignore-error 'overflow-error + (truncate v))) + (ok (= v truncated))) + (push (cons truncated truncated) (range cstr)))) (cl-loop with vals-to-add for (l . h) in (range cstr) diff --git a/test/src/comp-test-funcs.el b/test/src/comp-test-funcs.el index 5bae743d15..a465026fb3 100644 --- a/test/src/comp-test-funcs.el +++ b/test/src/comp-test-funcs.el @@ -667,6 +667,14 @@ (while (comp-test-no-return-3) (comp-test-no-return-3)))) +(defun comp-test-=-nan (x) + (when (= x 0.0e+NaN) + x)) + +(defun comp-test-=-infinity (x) + (when (= x 1.0e+INF) + x)) + (provide 'comp-test-funcs) ;;; comp-test-funcs.el ends here commit 30810905de7662b36b7ac9275bb9cbb2a563c277 Author: Eli Zaretskii Date: Wed Mar 3 20:15:58 2021 +0200 Fix compilation warnings in --with-wide-int build on Windows * src/comp.c (emit_rvalue_from_emacs_uint) (emit_rvalue_from_lisp_word_tag): Fix comparison of unsigned values. (gcc_jit_context_new_rvalue_from_ptr): Define only if LISP_WORDS_ARE_POINTERS, to avoid compilation warning. (init_gccjit_functions): Load gcc_jit_context_new_rvalue_from_ptr only if LISP_WORDS_ARE_POINTERS. diff --git a/src/comp.c b/src/comp.c index 21d1c1a23c..d74f8328fd 100644 --- a/src/comp.c +++ b/src/comp.c @@ -179,8 +179,10 @@ DEF_DLL_FN (gcc_jit_rvalue *, gcc_jit_context_new_comparison, enum gcc_jit_comparison op, gcc_jit_rvalue *a, gcc_jit_rvalue *b)); DEF_DLL_FN (gcc_jit_rvalue *, gcc_jit_context_new_rvalue_from_long, (gcc_jit_context *ctxt, gcc_jit_type *numeric_type, long value)); +#if LISP_WORDS_ARE_POINTERS DEF_DLL_FN (gcc_jit_rvalue *, gcc_jit_context_new_rvalue_from_ptr, (gcc_jit_context *ctxt, gcc_jit_type *pointer_type, void *value)); +#endif DEF_DLL_FN (gcc_jit_rvalue *, gcc_jit_context_new_string_literal, (gcc_jit_context *ctxt, const char *value)); DEF_DLL_FN (gcc_jit_rvalue *, gcc_jit_context_new_unary_op, @@ -290,7 +292,9 @@ init_gccjit_functions (void) LOAD_DLL_FN (library, gcc_jit_context_new_param); LOAD_DLL_FN (library, gcc_jit_context_new_rvalue_from_int); LOAD_DLL_FN (library, gcc_jit_context_new_rvalue_from_long); +#if LISP_WORDS_ARE_POINTERS LOAD_DLL_FN (library, gcc_jit_context_new_rvalue_from_ptr); +#endif LOAD_DLL_FN (library, gcc_jit_context_new_string_literal); LOAD_DLL_FN (library, gcc_jit_context_new_struct_type); LOAD_DLL_FN (library, gcc_jit_context_new_unary_op); @@ -357,7 +361,9 @@ init_gccjit_functions (void) #define gcc_jit_context_new_param fn_gcc_jit_context_new_param #define gcc_jit_context_new_rvalue_from_int fn_gcc_jit_context_new_rvalue_from_int #define gcc_jit_context_new_rvalue_from_long fn_gcc_jit_context_new_rvalue_from_long -#define gcc_jit_context_new_rvalue_from_ptr fn_gcc_jit_context_new_rvalue_from_ptr +#if LISP_WORDS_ARE_POINTERS +# define gcc_jit_context_new_rvalue_from_ptr fn_gcc_jit_context_new_rvalue_from_ptr +#endif #define gcc_jit_context_new_string_literal fn_gcc_jit_context_new_string_literal #define gcc_jit_context_new_struct_type fn_gcc_jit_context_new_struct_type #define gcc_jit_context_new_unary_op fn_gcc_jit_context_new_unary_op @@ -1137,7 +1143,7 @@ static gcc_jit_rvalue * emit_rvalue_from_emacs_uint (EMACS_UINT val) { #ifdef WIDE_EMACS_INT - if (val > LONG_MAX || val < LONG_MIN) + if (val > ULONG_MAX) return emit_rvalue_from_long_long (comp.emacs_uint_type, val); #endif return gcc_jit_context_new_rvalue_from_long (comp.ctxt, @@ -1159,7 +1165,7 @@ static gcc_jit_rvalue * emit_rvalue_from_lisp_word_tag (Lisp_Word_tag val) { #ifdef WIDE_EMACS_INT - if (val > LONG_MAX || val < LONG_MIN) + if (val > ULONG_MAX) return emit_rvalue_from_long_long (comp.lisp_word_tag_type, val); #endif return gcc_jit_context_new_rvalue_from_long (comp.ctxt, commit e5a0d4c42583fe38e38ab7782b8928ca54f82fad Author: Eli Zaretskii Date: Wed Mar 3 19:58:20 2021 +0200 Avoid aborting on MS-Windows at startup * src/emacs.c (set_invocation_vars) [WINDOWSNT]: If argv0 is not an absolute file name, obtain the absolute file name of the Emacs executable from 'w32_my_exename'. diff --git a/src/emacs.c b/src/emacs.c index d541b41f3f..ec62c19e38 100644 --- a/src/emacs.c +++ b/src/emacs.c @@ -37,6 +37,7 @@ along with GNU Emacs. If not, see . */ #include #include #include +#include /* for IS_ABSOLUTE_FILE_NAME */ #include "w32.h" #include "w32heap.h" #endif @@ -433,6 +434,12 @@ set_invocation_vars (char *argv0, char const *original_pwd) { char argv0_1[MAX_UTF8_PATH]; + /* Avoid calling 'openp' below, as we aren't ready for that yet: + emacs_dir is not yet defined in the environment, and therefore + emacs_root_dir, called by expand-file-name, will abort. */ + if (!IS_ABSOLUTE_FILE_NAME (argv0)) + argv0 = w32_my_exename (); + if (filename_from_ansi (argv0, argv0_1) == 0) raw_name = build_unibyte_string (argv0_1); else @@ -451,6 +458,11 @@ set_invocation_vars (char *argv0, char const *original_pwd) Vinvocation_name = Ffile_name_nondirectory (raw_name); Vinvocation_directory = Ffile_name_directory (raw_name); +#ifdef WINDOWSNT + eassert (!NILP (Vinvocation_directory) + && !NILP (Ffile_name_absolute_p (Vinvocation_directory))); +#endif + /* If we got no directory in argv0, search PATH to find where Emacs actually came from. */ if (NILP (Vinvocation_directory)) commit 4f90b0b6e6249597cf2e1450b5b9d7f6522c049f Author: Eli Zaretskii Date: Wed Mar 3 13:59:08 2021 +0200 Improve NEWS entries about native-compilation * etc/NEWS: Add an entry about native-compilation. Improve wording of the entry about 'package-native-compile'. diff --git a/etc/NEWS b/etc/NEWS index a37a38c2c6..a5ea7eb07b 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -24,6 +24,11 @@ applies, and please also update docstrings as needed. * Installation Changes in Emacs 28.1 +** Emacs now optionally supports native compilation of Lisp files. +To enable, configure Emacs with the '--with-native-compilation' option +to the 'configure' script. This requires to have the libgccjit +library to be installed and functional. + -- ** Support for building with Motif has been removed. @@ -1149,9 +1154,13 @@ key binding / u package-menu-filter-upgradable / / package-menu-filter-clear -*** Option to automatically native compile packages on installation. -Customize the user option `package-native-compile' to enable automatic -native compilation of packages on installation. +*** Option to automatically native-compile packages upon installation. +Customize the user option 'package-native-compile' to enable automatic +native compilation of packages when they are installed. That option +is nil by default; if set non-nil, and if your Emacs was built with +native-compilation support, each package will be natively compiled +when it is installed, by invoking an asynchronous Emacs subprocess to +run the native-compilation of the package files. --- *** Column widths in 'list-packages' display can now be customized. commit 8c7228e8cde9a33f8128933f991f6432e58cfde3 Author: Andrea Corallo Date: Tue Mar 2 08:43:39 2021 +0100 Fix = propagation semantic for constrained inputs * lisp/emacs-lisp/comp-cstr.el (comp-cstr): Synthesize `comp-cstr-shallow-copy'. (comp-cstr-=): Relax inputs before intersecting them. * test/src/comp-tests.el (comp-tests-type-spec-tests): Add three tests. diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el index d98ef681b5..996502b286 100644 --- a/lisp/emacs-lisp/comp-cstr.el +++ b/lisp/emacs-lisp/comp-cstr.el @@ -71,7 +71,7 @@ (irange &aux (range (list irange)) (typeset ()))) - (:copier nil)) + (:copier comp-cstr-shallow-copy)) "Internal representation of a type/value constraint." (typeset '(t) :type list :documentation "List of possible types the mvar can assume. @@ -859,17 +859,36 @@ Non memoized version of `comp-cstr-intersection-no-mem'." (null (neg cstr)) (equal (typeset cstr) '(cons))))) -(defun comp-cstr-= (dst old-dst src) - "Constraint DST being = SRC." +(defun comp-cstr-= (dst op1 op2) + "Constraint OP1 being = OP2 setting the result into DST." (with-comp-cstr-accessors - (comp-cstr-intersection dst old-dst src) - (cl-loop for v in (valset dst) - when (and (floatp v) - (= v (truncate v))) - do (push (cons (truncate v) (truncate v)) (range dst))) - (cl-loop for (l . h) in (range dst) - when (eql l h) - do (push (float l) (valset dst))))) + (cl-flet ((relax-cstr (cstr) + (setf cstr (comp-cstr-shallow-copy cstr)) + ;; If can be any float extend it to all integers. + (when (memq 'float (typeset cstr)) + (setf (range cstr) '((- . +)))) + ;; For each float value that can be represented + ;; precisely as an integer add the integer as well. + (cl-loop + for v in (valset cstr) + when (and (floatp v) + (= v (truncate v))) + do (push (cons (truncate v) (truncate v)) (range cstr))) + (cl-loop + with vals-to-add + for (l . h) in (range cstr) + ;; If an integer range reduces to single value add + ;; its float value too. + if (eql l h) + do (push (float l) vals-to-add) + ;; Otherwise can be any float. + else + do (cl-pushnew 'float (typeset cstr)) + (cl-return cstr) + finally (setf (valset cstr) + (append vals-to-add (valset cstr)))) + cstr)) + (comp-cstr-intersection dst (relax-cstr op1) (relax-cstr op2))))) (defun comp-cstr-> (dst old-dst src) "Constraint DST being > than SRC. diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 651df33296..3f007d2a59 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -1293,7 +1293,34 @@ Return a list of results." (if (equal x '(1 2 3)) x (error ""))) - cons))) + cons) + + ;; 69 + ((defun comp-tests-ret-type-spec-f (x) + (if (and (floatp x) + (= x 0)) + x + (error ""))) + ;; Conservative (see cstr relax in `comp-cstr-='). + (or (member 0.0) (integer 0 0))) + + ;; 70 + ((defun comp-tests-ret-type-spec-f (x) + (if (and (integer x) + (= x 0)) + x + (error ""))) + ;; Conservative (see cstr relax in `comp-cstr-='). + (or (member 0.0) (integer 0 0))) + + ;; 71 + ((defun comp-tests-ret-type-spec-f (x y) + (if (and (floatp x) + (integerp y) + (= x y)) + x + (error ""))) + (or float integer)))) (defun comp-tests-define-type-spec-test (number x) `(comp-deftest ,(intern (format "ret-type-spec-%d" number)) () commit 3d014e1bf48f661f0b229ddf735608ff0ba7cfe6 Author: Andrea Corallo Date: Mon Mar 1 19:39:00 2021 +0100 Fix `eql' `equal' propagation of non hash consed values (bug#46843) Extend assumes allowing the following form: (assume dst (and-nhc src1 src2)) `and-nhc' assume operator allow for constraining correctly intersections where non hash consed values are not propagated as values but rather promoted to their types. * lisp/emacs-lisp/comp-cstr.el (comp-cstr-intersection-no-hashcons): New function. * lisp/emacs-lisp/comp.el (comp-emit-assume): Logic update to emit `and-nhc' operator (implemented in fwprop by `comp-cstr-intersection-no-hashcons'). (comp-add-cond-cstrs): Map `eq' to `and' assume operator and `equal' `eql' into `and-nhc'. (comp-fwprop-insn): Update to handle `and-nhc'. * test/src/comp-tests.el (comp-tests-type-spec-tests): Add two tests covering `eql' and `equal' propagation of non hash consed values. diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el index bd1e04fb0b..d98ef681b5 100644 --- a/lisp/emacs-lisp/comp-cstr.el +++ b/lisp/emacs-lisp/comp-cstr.el @@ -968,6 +968,28 @@ DST is returned." (neg dst) (neg res)) res))) +(defun comp-cstr-intersection-no-hashcons (dst &rest srcs) + "Combine SRCS by intersection set operation setting the result in DST. +Non hash consed values are not propagated as values but rather +promoted to their types. +DST is returned." + (with-comp-cstr-accessors + (apply #'comp-cstr-intersection dst srcs) + (let (strip-values strip-types) + (cl-loop for v in (valset dst) + unless (or (symbolp v) + (fixnump v)) + do (push v strip-values) + (push (type-of v) strip-types)) + (when strip-values + (setf (typeset dst) (comp-union-typesets (typeset dst) strip-types) + (valset dst) (cl-set-difference (valset dst) strip-values))) + (cl-loop for (l . h) in (range dst) + when (or (bignump l) (bignump h)) + do (setf (range dst) '((- . +))) + (cl-return)) + dst))) + (defun comp-cstr-intersection-make (&rest srcs) "Combine SRCS by intersection set operation and return a new constraint." (apply #'comp-cstr-intersection (make-comp-cstr) srcs)) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 03999d3e66..af14afd42b 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2266,20 +2266,20 @@ The assume is emitted at the beginning of the block BB." (let ((lhs-slot (comp-mvar-slot lhs))) (cl-assert lhs-slot) (pcase kind - ('and + ((or 'and 'and-nhc) (if (comp-mvar-p rhs) (let ((tmp-mvar (if negated (make-comp-mvar :slot (comp-mvar-slot rhs)) rhs))) (push `(assume ,(make-comp-mvar :slot lhs-slot) - (and ,lhs ,tmp-mvar)) + (,kind ,lhs ,tmp-mvar)) (comp-block-insns bb)) (if negated (push `(assume ,tmp-mvar (not ,rhs)) (comp-block-insns bb)))) ;; If is only a constraint we can negate it directly. (push `(assume ,(make-comp-mvar :slot lhs-slot) - (and ,lhs ,(if negated + (,kind ,lhs ,(if negated (comp-cstr-negation-make rhs) rhs))) (comp-block-insns bb)))) @@ -2431,11 +2431,14 @@ TARGET-BB-SYM is the symbol name of the target block." (cl-loop with target-mvar1 = (comp-cond-cstrs-target-mvar op1 (car insns-seq) b) with target-mvar2 = (comp-cond-cstrs-target-mvar op2 (car insns-seq) b) - with equality = (comp-equality-fun-p fun) for branch-target-cell on blocks for branch-target = (car branch-target-cell) for negated in '(t nil) - for kind = (if equality 'and fun) + for kind = (cl-case fun + (equal 'and-nhc) + (eql 'and-nhc) + (eq 'and) + (t fun)) when (or (comp-mvar-used-p target-mvar1) (comp-mvar-used-p target-mvar2)) do @@ -3102,6 +3105,8 @@ Fold the call in case." (cl-case kind (and (apply #'comp-cstr-intersection lval operands)) + (and-nhc + (apply #'comp-cstr-intersection-no-hashcons lval operands)) (not ;; Prevent double negation! (unless (comp-cstr-neg (car operands)) diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 0598eeeb05..651df33296 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -1279,7 +1279,21 @@ Return a list of results." (if (= x 1) x (error ""))) - (or (member 1.0) (integer 1 1))))) + (or (member 1.0) (integer 1 1))) + + ;; 66 + ((defun comp-tests-ret-type-spec-f (x) + (if (eql x 0.0) + x + (error ""))) + float) + + ;; 67 + ((defun comp-tests-ret-type-spec-f (x) + (if (equal x '(1 2 3)) + x + (error ""))) + cons))) (defun comp-tests-define-type-spec-test (number x) `(comp-deftest ,(intern (format "ret-type-spec-%d" number)) () commit 5bc08559e8f171eafc3c034232f8cfd9eaf89862 Author: Andrea Corallo Date: Sat Feb 27 22:00:11 2021 +0100 Don't treat '=' as simple equality emitting constraints (bug#46812) Extend assumes allowing the following form (assume dst (= src1 src2)) to caputure '=' semanting during fwprop handling float integer conversions. * lisp/emacs-lisp/comp.el (comp-equality-fun-p): Don't treat '=' as simple equality. (comp-arithm-cmp-fun-p, comp-negate-arithm-cmp-fun) (comp-reverse-arithm-fun): Rename and add '=' '!='. (comp-emit-assume, comp-add-cond-cstrs, comp-fwprop-insn): Update for new function nameing and to handle '='. * lisp/emacs-lisp/comp-cstr.el (comp-cstr-=): New function. * test/src/comp-tests.el (comp-tests-type-spec-tests): Add a bunch of '=' specific tests. diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el index 89815f03b5..bd1e04fb0b 100644 --- a/lisp/emacs-lisp/comp-cstr.el +++ b/lisp/emacs-lisp/comp-cstr.el @@ -859,6 +859,18 @@ Non memoized version of `comp-cstr-intersection-no-mem'." (null (neg cstr)) (equal (typeset cstr) '(cons))))) +(defun comp-cstr-= (dst old-dst src) + "Constraint DST being = SRC." + (with-comp-cstr-accessors + (comp-cstr-intersection dst old-dst src) + (cl-loop for v in (valset dst) + when (and (floatp v) + (= v (truncate v))) + do (push (cons (truncate v) (truncate v)) (range dst))) + (cl-loop for (l . h) in (range dst) + when (eql l h) + do (push (float l) (valset dst))))) + (defun comp-cstr-> (dst old-dst src) "Constraint DST being > than SRC. SRC can be either a comp-cstr or an integer." diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index e71d4abbd5..03999d3e66 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -906,11 +906,11 @@ To be used by all entry points." (defun comp-equality-fun-p (function) "Equality functions predicate for FUNCTION." - (when (memq function '(eq eql = equal)) t)) + (when (memq function '(eq eql equal)) t)) -(defun comp-range-cmp-fun-p (function) - "Predicate for range comparision functions." - (when (memq function '(> < >= <=)) t)) +(defun comp-arithm-cmp-fun-p (function) + "Predicate for arithmetic comparision functions." + (when (memq function '(= > < >= <=)) t)) (defun comp-set-op-p (op) "Assignment predicate for OP." @@ -2238,17 +2238,21 @@ into the C code forwarding the compilation unit." else do (comp-collect-mvars args)))) -(defun comp-negate-range-cmp-fun (function) - "Negate FUNCTION." +(defun comp-negate-arithm-cmp-fun (function) + "Negate FUNCTION. +Return nil if we don't want to emit constraints for its +negation." (cl-ecase function + (= nil) (> '<=) (< '>=) (>= '<) (<= '>))) -(defun comp-reverse-cmp-fun (function) +(defun comp-reverse-arithm-fun (function) "Reverse FUNCTION." (cl-case function + (= '=) (> '<) (< '>) (>= '<=) @@ -2279,15 +2283,16 @@ The assume is emitted at the beginning of the block BB." (comp-cstr-negation-make rhs) rhs))) (comp-block-insns bb)))) - ((pred comp-range-cmp-fun-p) - (let ((kind (if negated - (comp-negate-range-cmp-fun kind) - kind))) + ((pred comp-arithm-cmp-fun-p) + (when-let ((kind (if negated + (comp-negate-arithm-cmp-fun kind) + kind))) (push `(assume ,(make-comp-mvar :slot lhs-slot) (,kind ,lhs ,(if-let* ((vld (comp-cstr-imm-vld-p rhs)) (val (comp-cstr-imm rhs)) - (ok (integerp val))) + (ok (and (integerp val) + (not (memq kind '(= !=)))))) val (make-comp-mvar :slot (comp-mvar-slot rhs))))) (comp-block-insns bb)))) @@ -2418,7 +2423,7 @@ TARGET-BB-SYM is the symbol name of the target block." (`((set ,(and (pred comp-mvar-p) cmp-res) (,(pred comp-call-op-p) ,(and (or (pred comp-equality-fun-p) - (pred comp-range-cmp-fun-p)) + (pred comp-arithm-cmp-fun-p)) fun) ,op1 ,op2)) ;; (comment ,_comment-str) @@ -2441,7 +2446,7 @@ TARGET-BB-SYM is the symbol name of the target block." (comp-maybe-add-vmvar op2 cmp-res prev-insns-seq) block-target negated)) (when (comp-mvar-used-p target-mvar2) - (comp-emit-assume (comp-reverse-cmp-fun kind) + (comp-emit-assume (comp-reverse-arithm-fun kind) target-mvar2 (comp-maybe-add-vmvar op1 cmp-res prev-insns-seq) block-target negated))) @@ -3108,7 +3113,9 @@ Fold the call in case." (< (comp-cstr-< lval (car operands) (cadr operands))) (<= - (comp-cstr-<= lval (car operands) (cadr operands))))) + (comp-cstr-<= lval (car operands) (cadr operands))) + (= + (comp-cstr-= lval (car operands) (cadr operands))))) (`(setimm ,lval ,v) (setf (comp-cstr-imm lval) v)) (`(phi ,lval . ,rest) diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 402ba7cd8b..0598eeeb05 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -891,24 +891,24 @@ Return a list of results." ;; 10 ((defun comp-tests-ret-type-spec-f (x) - (if (= x 3) + (if (eql x 3) x 'foo)) (or (member foo) (integer 3 3))) ;; 11 ((defun comp-tests-ret-type-spec-f (x) - (if (= 3 x) + (if (eql 3 x) x 'foo)) (or (member foo) (integer 3 3))) ;; 12 ((defun comp-tests-ret-type-spec-f (x) - (if (= x 3) + (if (eql x 3) 'foo x)) - (or (member foo) marker number)) + (not (integer 3 3))) ;; 13 ((defun comp-tests-ret-type-spec-f (x y) @@ -1214,7 +1214,7 @@ Return a list of results." ;; 57 ((defun comp-tests-ret-type-spec-f (x) (unless (or (eq x 'foo) - (= x 3)) + (eql x 3)) (error "Not foo or 3")) x) (or (member foo) (integer 3 3))) @@ -1244,7 +1244,42 @@ Return a list of results." (>= x y)) x (error ""))) - (or float (integer 3 10))))) + (or float (integer 3 10))) + + ;; 61 + ((defun comp-tests-ret-type-spec-f (x) + (if (= x 1.0) + x + (error ""))) + (or (member 1.0) (integer 1 1))) + + ;; 62 + ((defun comp-tests-ret-type-spec-f (x) + (if (= x 1.0) + x + (error ""))) + (or (member 1.0) (integer 1 1))) + + ;; 63 + ((defun comp-tests-ret-type-spec-f (x) + (if (= x 1.1) + x + (error ""))) + (member 1.1)) + + ;; 64 + ((defun comp-tests-ret-type-spec-f (x) + (if (= x 1) + x + (error ""))) + (or (member 1.0) (integer 1 1))) + + ;; 65 + ((defun comp-tests-ret-type-spec-f (x) + (if (= x 1) + x + (error ""))) + (or (member 1.0) (integer 1 1))))) (defun comp-tests-define-type-spec-test (number x) `(comp-deftest ,(intern (format "ret-type-spec-%d" number)) () commit 2acc46b55bdf518ece6301913ffa074f31563fa4 Author: Andrea Corallo Date: Sat Feb 27 21:26:41 2021 +0100 Migrate and rename a bunch of functions from comp.el to comp-cstr.el * lisp/emacs-lisp/comp-cstr.el (comp-cstr-imm-vld-p) (comp-cstr-imm, comp-cstr-fixnum-p, comp-cstr-symbol-p) (comp-cstr-cons-p): Move and rename from 'comp.el'. * lisp/emacs-lisp/comp.el (comp-mvar-type-hint-match-p) (make-comp-mvar, comp-emit-assume, comp-fwprop-prologue) (comp-function-foldable-p, comp-function-call-maybe-fold) (comp-fwprop-call, comp-fwprop-insn, comp-call-optim-func) (comp-compute-function-type): Update for renamed functions. * src/comp.c (emit_mvar_rval): Likewise. * test/src/comp-tests.el (comp-tests-mentioned-p-1) (comp-tests-cond-rw-checker-val): Likewise. diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el index c294c53b6b..89815f03b5 100644 --- a/lisp/emacs-lisp/comp-cstr.el +++ b/lisp/emacs-lisp/comp-cstr.el @@ -789,6 +789,76 @@ Non memoized version of `comp-cstr-intersection-no-mem'." ;;; Entry points. +(defun comp-cstr-imm-vld-p (cstr) + "Return t if one and only one immediate value can be extracted from CSTR." + (with-comp-cstr-accessors + (when (and (null (typeset cstr)) + (null (neg cstr))) + (let* ((v (valset cstr)) + (r (range cstr)) + (valset-len (length v)) + (range-len (length r))) + (if (and (= valset-len 1) + (= range-len 0)) + t + (when (and (= valset-len 0) + (= range-len 1)) + (let* ((low (caar r)) + (high (cdar r))) + (and (integerp low) + (integerp high) + (= low high))))))))) + +(defun comp-cstr-imm (cstr) + "Return the immediate value of CSTR. +`comp-cstr-imm-vld-p' *must* be satisfied before calling +`comp-cstr-imm'." + (declare (gv-setter + (lambda (val) + `(with-comp-cstr-accessors + (if (integerp ,val) + (setf (typeset ,cstr) nil + (range ,cstr) (list (cons ,val ,val))) + (setf (typeset ,cstr) nil + (valset ,cstr) (list ,val))))))) + (with-comp-cstr-accessors + (let ((v (valset cstr))) + (if (= (length v) 1) + (car v) + (caar (range cstr)))))) + +(defun comp-cstr-fixnum-p (cstr) + "Return t if CSTR is certainly a fixnum." + (with-comp-cstr-accessors + (when (null (neg cstr)) + (when-let (range (range cstr)) + (let* ((low (caar range)) + (high (cdar (last range)))) + (unless (or (eq low '-) + (< low most-negative-fixnum) + (eq high '+) + (> high most-positive-fixnum)) + t)))))) + +(defun comp-cstr-symbol-p (cstr) + "Return t if CSTR is certainly a symbol." + (with-comp-cstr-accessors + (and (null (range cstr)) + (null (neg cstr)) + (or (and (null (valset cstr)) + (equal (typeset cstr) '(symbol))) + (and (or (null (typeset cstr)) + (equal (typeset cstr) '(symbol))) + (cl-every #'symbolp (valset cstr))))))) + +(defsubst comp-cstr-cons-p (cstr) + "Return t if CSTR is certainly a cons." + (with-comp-cstr-accessors + (and (null (valset cstr)) + (null (range cstr)) + (null (neg cstr)) + (equal (typeset cstr) '(cons))))) + (defun comp-cstr-> (dst old-dst src) "Constraint DST being > than SRC. SRC can be either a comp-cstr or an integer." diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 09ae383492..e71d4abbd5 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -885,78 +885,12 @@ CFG is mutated by a pass.") :documentation "Slot number in the array if a number or 'scratch' for scratch slot.")) -(defun comp-mvar-value-vld-p (mvar) - "Return t if one single value can be extracted by the MVAR constrains." - (when (and (null (comp-mvar-typeset mvar)) - (null (comp-mvar-neg mvar))) - (let* ((v (comp-mvar-valset mvar)) - (r (comp-mvar-range mvar)) - (valset-len (length v)) - (range-len (length r))) - (if (and (= valset-len 1) - (= range-len 0)) - t - (when (and (= valset-len 0) - (= range-len 1)) - (let* ((low (caar r)) - (high (cdar r))) - (and (integerp low) - (integerp high) - (= low high)))))))) - -;; FIXME move these into cstr? - -(defun comp-mvar-value (mvar) - "Return the constant value of MVAR. -`comp-mvar-value-vld-p' *must* be satisfied before calling -`comp-mvar-const'." - (declare (gv-setter - (lambda (val) - `(if (integerp ,val) - (setf (comp-mvar-typeset ,mvar) nil - (comp-mvar-range ,mvar) (list (cons ,val ,val))) - (setf (comp-mvar-typeset ,mvar) nil - (comp-mvar-valset ,mvar) (list ,val)))))) - (let ((v (comp-mvar-valset mvar))) - (if (= (length v) 1) - (car v) - (caar (comp-mvar-range mvar))))) - -(defun comp-mvar-fixnum-p (mvar) - "Return t if MVAR is certainly a fixnum." - (when (null (comp-mvar-neg mvar)) - (when-let (range (comp-mvar-range mvar)) - (let* ((low (caar range)) - (high (cdar (last range)))) - (unless (or (eq low '-) - (< low most-negative-fixnum) - (eq high '+) - (> high most-positive-fixnum)) - t))))) - -(defun comp-mvar-symbol-p (mvar) - "Return t if MVAR is certainly a symbol." - (and (null (comp-mvar-range mvar)) - (null (comp-mvar-neg mvar)) - (or (and (null (comp-mvar-valset mvar)) - (equal (comp-mvar-typeset mvar) '(symbol))) - (and (or (null (comp-mvar-typeset mvar)) - (equal (comp-mvar-typeset mvar) '(symbol))) - (cl-every #'symbolp (comp-mvar-valset mvar)))))) - -(defsubst comp-mvar-cons-p (mvar) - "Return t if MVAR is certainly a cons." - (and (null (comp-mvar-valset mvar)) - (null (comp-mvar-range mvar)) - (null (comp-mvar-neg mvar)) - (equal (comp-mvar-typeset mvar) '(cons)))) - (defun comp-mvar-type-hint-match-p (mvar type-hint) "Match MVAR against TYPE-HINT. In use by the backend." (cl-ecase type-hint - (cons (comp-mvar-cons-p mvar)) - (fixnum (comp-mvar-fixnum-p mvar)))) + (cons (comp-cstr-cons-p mvar)) + (fixnum (comp-cstr-fixnum-p mvar)))) @@ -1501,7 +1435,7 @@ STACK-OFF is the index of the first slot frame involved." (let ((mvar (make--comp-mvar :slot slot))) (when const-vld (comp-add-const-to-relocs constant) - (setf (comp-mvar-value mvar) constant)) + (setf (comp-cstr-imm mvar) constant)) (when type (setf (comp-mvar-typeset mvar) (list type))) mvar)) @@ -2351,8 +2285,8 @@ The assume is emitted at the beginning of the block BB." kind))) (push `(assume ,(make-comp-mvar :slot lhs-slot) (,kind ,lhs - ,(if-let* ((vld (comp-mvar-value-vld-p rhs)) - (val (comp-mvar-value rhs)) + ,(if-let* ((vld (comp-cstr-imm-vld-p rhs)) + (val (comp-cstr-imm rhs)) (ok (integerp val))) val (make-comp-mvar :slot (comp-mvar-slot rhs))))) @@ -3077,7 +3011,7 @@ Forward propagate immediate involed in assignments." for insn in (comp-block-insns b) do (pcase insn (`(setimm ,lval ,v) - (setf (comp-mvar-value lval) v)))))) + (setf (comp-cstr-imm lval) v)))))) (defun comp-mvar-propagate (lval rval) "Propagate into LVAL properties of RVAL." @@ -3089,7 +3023,7 @@ Forward propagate immediate involed in assignments." (defun comp-function-foldable-p (f args) "Given function F called with ARGS return non-nil when optimizable." (and (comp-function-pure-p f) - (cl-every #'comp-mvar-value-vld-p args))) + (cl-every #'comp-cstr-imm-vld-p args))) (defun comp-function-call-maybe-fold (insn f args) "Given INSN when F is pure if all ARGS are known remove the function call. @@ -3102,10 +3036,10 @@ Return non-nil if the function is folded successfully." (cond ((eq f 'symbol-value) (when-let* ((arg0 (car args)) - (const (comp-mvar-value-vld-p arg0)) - (ok-to-optim (member (comp-mvar-value arg0) + (const (comp-cstr-imm-vld-p arg0)) + (ok-to-optim (member (comp-cstr-imm arg0) comp-symbol-values-optimizable))) - (rewrite-insn-as-setimm insn (symbol-value (comp-mvar-value + (rewrite-insn-as-setimm insn (symbol-value (comp-cstr-imm (car args)))))) ((comp-function-foldable-p f args) (ignore-errors @@ -3118,7 +3052,7 @@ Return non-nil if the function is folded successfully." ;; and know to be pure. (comp-func-byte-func f-in-ctxt) f)) - (value (comp-apply-in-env f (mapcar #'comp-mvar-value args)))) + (value (comp-apply-in-env f (mapcar #'comp-cstr-imm args)))) (rewrite-insn-as-setimm insn value))))))) (defun comp-fwprop-call (insn lval f args) @@ -3127,8 +3061,8 @@ F is the function being called with arguments ARGS. Fold the call in case." (unless (comp-function-call-maybe-fold insn f args) (when (and (eq 'funcall f) - (comp-mvar-value-vld-p (car args))) - (setf f (comp-mvar-value (car args)) + (comp-cstr-imm-vld-p (car args))) + (setf f (comp-cstr-imm (car args)) args (cdr args))) (when-let ((cstr-f (gethash f comp-known-func-cstr-h))) (let ((cstr (comp-cstr-f-ret cstr-f))) @@ -3176,7 +3110,7 @@ Fold the call in case." (<= (comp-cstr-<= lval (car operands) (cadr operands))))) (`(setimm ,lval ,v) - (setf (comp-mvar-value lval) v)) + (setf (comp-cstr-imm lval) v)) (`(phi ,lval . ,rest) (let* ((from-latch (cl-some (lambda (x) @@ -3337,11 +3271,11 @@ FUNCTION can be a function-name or byte compiled function." (pcase insn (`(set ,lval (callref funcall ,f . ,rest)) (when-let ((new-form (comp-call-optim-form-call - (comp-mvar-value f) rest))) + (comp-cstr-imm f) rest))) (setf insn `(set ,lval ,new-form)))) (`(callref funcall ,f . ,rest) (when-let ((new-form (comp-call-optim-form-call - (comp-mvar-value f) rest))) + (comp-cstr-imm f) rest))) (setf insn new-form))))))) (defun comp-call-optim (_) @@ -3539,7 +3473,7 @@ Set it into the `type' slot." ,(comp-cstr-to-type-spec res-mvar)))) (comp-add-const-to-relocs type) ;; Fix it up. - (setf (comp-mvar-value (comp-func-type func)) type)))) + (setf (comp-cstr-imm (comp-func-type func)) type)))) (defun comp-finalize-container (cont) "Finalize data container CONT." diff --git a/src/comp.c b/src/comp.c index 1a89e4e62a..21d1c1a23c 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1747,11 +1747,11 @@ emit_PURE_P (gcc_jit_rvalue *ptr) static gcc_jit_rvalue * emit_mvar_rval (Lisp_Object mvar) { - Lisp_Object const_vld = CALL1I (comp-mvar-value-vld-p, mvar); + Lisp_Object const_vld = CALL1I (comp-cstr-imm-vld-p, mvar); if (!NILP (const_vld)) { - Lisp_Object value = CALL1I (comp-mvar-value, mvar); + Lisp_Object value = CALL1I (comp-cstr-imm, mvar); if (comp.debug > 1) { Lisp_Object func = diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index fa84ffbc0b..402ba7cd8b 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -739,8 +739,8 @@ https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-03/msg00914.html." (cl-loop for y in insn when (cond ((consp y) (comp-tests-mentioned-p x y)) - ((and (comp-mvar-p y) (comp-mvar-value-vld-p y)) - (equal (comp-mvar-value y) x)) + ((and (comp-mvar-p y) (comp-cstr-imm-vld-p y)) + (equal (comp-cstr-imm y) x)) (t (equal x y))) return t)) @@ -1313,8 +1313,8 @@ Return a list of results." (lambda (insn) (pcase insn (`(return ,mvar) - (and (comp-mvar-value-vld-p mvar) - (eql (comp-mvar-value mvar) 123))))))))) + (and (comp-cstr-imm-vld-p mvar) + (eql (comp-cstr-imm mvar) 123))))))))) (defvar comp-tests-cond-rw-expected-type nil "Type to expect in `comp-tests-cond-rw-checker-type'.") commit 312deba5302a8136fa104b054af54572cc64ea5e Author: Andrea Corallo Date: Fri Feb 26 21:27:02 2021 +0100 * Canonicalize filenames on Windows before hashing (bug#46256) * src/comp.c (Fcomp_el_to_eln_filename): On Windowns canonicalize filenames before hashing. diff --git a/src/comp.c b/src/comp.c index a8b8ef95fa..1a89e4e62a 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3983,6 +3983,10 @@ If BASE-DIR is nil use the first entry in `comp-eln-load-path'. */) if (NILP (Ffile_exists_p (filename))) xsignal1 (Qfile_missing, filename); +#ifdef WINDOWSNT + filename = Fw32_long_file_name (filename); +#endif + Lisp_Object content_hash = comp_hash_source_file (filename); if (suffix_p (filename, ".gz")) @@ -4014,8 +4018,11 @@ If BASE-DIR is nil use the first entry in `comp-eln-load-path'. */) Lisp_Object sys_re = concat2 (build_string ("\\`[[:ascii:]]+"), Fregexp_quote (build_string ("/" PATH_REL_LOADSEARCH "/"))); - loadsearch_re_list = - list2 (sys_re, Fregexp_quote (build_string (PATH_DUMPLOADSEARCH "/"))); + Lisp_Object dump_load_search = build_string (PATH_DUMPLOADSEARCH "/"); +#ifdef WINDOWSNT + dump_load_search = Fw32_long_file_name (dump_load_search); +#endif + loadsearch_re_list = list2 (sys_re, Fregexp_quote (dump_load_search)); } Lisp_Object lds_re_tail = loadsearch_re_list; commit 42fc752a14b23be95f02b598930f13a96883d3a0 Author: Andrea Corallo Date: Fri Feb 26 20:11:31 2021 +0100 * Change native compiler configure flag into '--with-native-compilation' * configure.ac: Rename configure nativecomp flags into --with-native-compilation. diff --git a/configure.ac b/configure.ac index fe0dc921dc..3dff9ea2e2 100644 --- a/configure.ac +++ b/configure.ac @@ -484,7 +484,7 @@ OPTION_DEFAULT_ON([gnutls],[don't use -lgnutls for SSL/TLS support]) 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],[compile with Emacs Lisp native compiler support]) +OPTION_DEFAULT_OFF([native-compilation],[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)])], @@ -3786,7 +3786,7 @@ AC_DEFUN([libgccjit_not_found], [ AC_MSG_ERROR([elisp native compiler requested but libgccjit not found. Please try installing libgccjit or similar package. If you are sure you want Emacs compiled without elisp native compiler, pass - --without-nativecomp + --without-native-compilation to configure.])]) AC_DEFUN([libgccjit_dev_not_found], [ @@ -3808,7 +3808,7 @@ Here instructions on how to compile and install libgccjit from source: HAVE_NATIVE_COMP=no LIBGCCJIT_LIB= -if test "${with_nativecomp}" != "no"; then +if test "${with_native_compilation}" != "no"; then if test "${HAVE_PDUMPER}" = no; then AC_MSG_ERROR(['--with-nativecomp' requires '--with-dumping=pdumper']) fi commit b84c1727ea035cd47ab9ac5cb6627d402896f21d Author: Andrea Corallo Date: Fri Feb 26 19:57:41 2021 +0100 * Interactive tag native compilation function in emacs-lisp-mode * lisp/progmodes/elisp-mode.el (emacs-lisp-native-compile-and-load): Tag it for `emacs-lisp-mode'. diff --git a/lisp/progmodes/elisp-mode.el b/lisp/progmodes/elisp-mode.el index 408da8a962..d040fdda28 100644 --- a/lisp/progmodes/elisp-mode.el +++ b/lisp/progmodes/elisp-mode.el @@ -212,7 +212,7 @@ Load the compiled code when finished. Use `emacs-lisp-byte-compile-and-load' in combination with `comp-deferred-compilation' set to `t' to achieve asynchronous native compilation." - (interactive) + (interactive nil emacs-lisp-mode) (emacs-lisp--before-compile-buffer) (load (native-compile buffer-file-name))) commit 5c922cc3a4b0677805a678267df2b7598e92bb83 Merge: cedc55041e 496fa1c03b Author: Andrea Corallo Date: Fri Feb 26 19:54:59 2021 +0100 Merge remote-tracking branch 'savannah/master' into native-comp commit cedc55041ea5179dcb389845d2d0e3562060cab9 Author: Stefan Kangas Date: Fri Feb 26 18:03:19 2021 +0100 Make some defcustom types stricter in comp.el * lisp/emacs-lisp/comp.el (comp-speed, comp-debug, comp-verbose) (comp-async-jobs-number, comp-async-env-modifier-form): Use stricter types. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 7c702ca497..09ae383492 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -52,8 +52,8 @@ - 2 max optimization level fully adherent to the language semantic. - 3 max optimization level, to be used only when necessary. Warning: the compiler is free to perform dangerous optimizations." - :type 'number - :safe #'numberp + :type 'integer + :safe #'integerp :version "28.1") (defcustom comp-debug 0 @@ -64,8 +64,8 @@ This intended for debugging the compiler itself. - 1 emit debug symbols and dump pseudo C code. - 2 dump gcc passes and libgccjit log file. - 3 dump libgccjit reproducers." - :type 'number - :safe #'numberp + :type 'integer + :safe #'natnump :version "28.1") (defcustom comp-verbose 0 @@ -75,7 +75,8 @@ This intended for debugging the compiler itself. - 1 final limple is logged. - 2 LAP and final limple and some pass info are logged. - 3 max verbosity." - :type 'number + :type 'integer + :risky t :version "28.1") (defcustom comp-always-compile nil @@ -109,7 +110,8 @@ Skip if any is matching." (defcustom comp-async-jobs-number 0 "Default number of processes used for async compilation. When zero use half of the CPUs or at least one." - :type 'number + :type 'integer + :risky t :version "28.1") ;; FIXME: This an abnormal hook, and should be renamed to something @@ -130,6 +132,7 @@ compilation input." "Form evaluated before compilation by each asynchronous compilation worker. Usable to modify the compiler environment." :type 'list + :risky t :version "28.1") (defcustom comp-async-report-warnings-errors t commit 720bd747a80a5fe2f774997ae85d6607b5627e56 Author: Stefan Kangas Date: Fri Feb 26 17:56:36 2021 +0100 Add :version tags to defcustoms in comp.el * lisp/emacs-lisp/comp.el (comp-speed, comp-debug, comp-verbose) (comp-never-optimize-functions, comp-async-jobs-number) (comp-async-cu-done-hook, comp-async-all-done-hook) (comp-async-env-modifier-form) (comp-async-report-warnings-errors, comp-native-driver-options) (comp-libgccjit-reproducer): Add :version tags. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index d559fa0251..7c702ca497 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -54,7 +54,7 @@ Warning: the compiler is free to perform dangerous optimizations." :type 'number :safe #'numberp - :group 'comp) + :version "28.1") (defcustom comp-debug 0 "Compiler debug level. From 0 to 3. @@ -66,7 +66,7 @@ This intended for debugging the compiler itself. - 3 dump libgccjit reproducers." :type 'number :safe #'numberp - :group 'comp) + :version "28.1") (defcustom comp-verbose 0 "Compiler verbosity. From 0 to 3. @@ -75,23 +75,27 @@ This intended for debugging the compiler itself. - 1 final limple is logged. - 2 LAP and final limple and some pass info are logged. - 3 max verbosity." - :type 'number) + :type 'number + :version "28.1") (defcustom comp-always-compile nil "Unconditionally (re-)compile all files." - :type 'boolean) + :type 'boolean + :version "28.1") (defcustom comp-deferred-compilation-deny-list '() "List of regexps to exclude files from deferred native compilation. Skip if any is matching." - :type 'list) + :type 'list + :version "28.1") (defcustom comp-bootstrap-deny-list '() "List of regexps to exclude files from native compilation during bootstrap. Skip if any is matching." - :type 'list) + :type 'list + :version "28.1") (defcustom comp-never-optimize-functions '(;; The following two are mandatory for Emacs to be working @@ -99,12 +103,14 @@ Skip if any is matching." ;; REMOVE. macroexpand rename-buffer) "Primitive functions for which we do not perform trampoline optimization." - :type 'list) + :type 'list + :version "28.1") (defcustom comp-async-jobs-number 0 "Default number of processes used for async compilation. When zero use half of the CPUs or at least one." - :type 'number) + :type 'number + :version "28.1") ;; FIXME: This an abnormal hook, and should be renamed to something ;; like `comp-async-cu-done-function'. @@ -112,16 +118,19 @@ When zero use half of the CPUs or at least one." "Hook run after asynchronously compiling a single compilation unit. The argument FILE passed to the function is the filename used as compilation input." - :type 'hook) + :type 'hook + :version "28.1") (defcustom comp-async-all-done-hook nil "Hook run after asynchronously compiling all input files." - :type 'hook) + :type 'hook + :version "28.1") (defcustom comp-async-env-modifier-form nil "Form evaluated before compilation by each asynchronous compilation worker. Usable to modify the compiler environment." - :type 'list) + :type 'list + :version "28.1") (defcustom comp-async-report-warnings-errors t "Whether to report warnings and errors from asynchronous native compilation. @@ -138,7 +147,8 @@ environment, it is more sensitive to such omissions, and might be unable to compile such Lisp source files correctly. Set this variable to nil if these warnings annoy you." - :type 'boolean) + :type 'boolean + :version "28.1") (defcustom comp-async-query-on-exit nil "Whether to query the user about killing async compilations when exiting. @@ -146,7 +156,8 @@ If this is non-nil, Emacs will ask for confirmation to exit and kill the asynchronous native compilations if any are running. If nil, when you exit Emacs, it will silently kill those asynchronous compilations even if `confirm-kill-processes' is non-nil." - :type 'boolean) + :type 'boolean + :version "28.1") (defcustom comp-native-driver-options nil "Options passed verbatim to the native compiler's backend driver. @@ -155,13 +166,15 @@ affecting the assembler and linker are likely to be useful. Passing these options is only available in libgccjit version 9 and above." - :type 'list) + :type 'list + :version "28.1") (defcustom comp-libgccjit-reproducer nil "When non-nil produce a libgccjit reproducer. The reproducer is a file ELNFILENAME_libgccjit_repro.c deposed in the .eln output directory." - :type 'boolean) + :type 'boolean + :version "28.1") (defvar comp-log-time-report nil "If non-nil, log a time report for each pass.") commit 5540d73441a8fb518cc876ba01561d0875739283 Author: Eli Zaretskii Date: Fri Feb 26 16:50:41 2021 +0200 Fix last change * lisp/emacs-lisp/comp.el (comp-async-report-warnings-errors): Improve wording of the doc string. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 184aef489d..d559fa0251 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -126,16 +126,18 @@ Usable to modify the compiler environment." (defcustom comp-async-report-warnings-errors t "Whether to report warnings and errors from asynchronous native compilation. -When native compilation happens asynchronously this can produce -warnings and errors, some of these diagnostic messages might not be -emitted by the first synchronous byte-compilation. The typical case -for that is byte-compiling a file that is missing to require a -necessary feature while having it already loaded into the environment. - -As asynchronous native compilation always starts from a fresh -environment it is more sensitive into highlighting issues about non -consistent source files and might not be able to compile correctly -these." +When native compilation happens asynchronously, it can produce +warnings and errors, some of which might not be emitted by a +byte-compilation. The typical case for that is native-compiling +a file that is missing some `require' of a necessary feature, +while having it already loaded into the environment when +byte-compiling. + +As asynchronous native compilation always starts from a pristine +environment, it is more sensitive to such omissions, and might be +unable to compile such Lisp source files correctly. + +Set this variable to nil if these warnings annoy you." :type 'boolean) (defcustom comp-async-query-on-exit nil commit ad74b1b2b64cfe989213fc69337dbb0eda858d10 Author: Andrea Corallo Date: Fri Feb 26 15:15:06 2021 +0100 * Improve `comp-async-report-warnings-errors' docstring * lisp/emacs-lisp/comp.el (comp-async-report-warnings-errors): Improve docstring. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index c242c5c871..184aef489d 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -124,7 +124,18 @@ Usable to modify the compiler environment." :type 'list) (defcustom comp-async-report-warnings-errors t - "Whether to report warnings and errors from asynchronous native compilation." + "Whether to report warnings and errors from asynchronous native compilation. + +When native compilation happens asynchronously this can produce +warnings and errors, some of these diagnostic messages might not be +emitted by the first synchronous byte-compilation. The typical case +for that is byte-compiling a file that is missing to require a +necessary feature while having it already loaded into the environment. + +As asynchronous native compilation always starts from a fresh +environment it is more sensitive into highlighting issues about non +consistent source files and might not be able to compile correctly +these." :type 'boolean) (defcustom comp-async-query-on-exit nil commit 3266093af97420d2b8b4108f2fc0a7d02d4a34b3 Author: Eli Zaretskii Date: Fri Feb 26 16:08:44 2021 +0200 Improve documentation of last change * lisp/emacs-lisp/comp.el (comp-async-query-on-exit) (comp-async-report-warnings-errors): Improve wording. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 6af4ee2beb..c242c5c871 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -124,11 +124,15 @@ Usable to modify the compiler environment." :type 'list) (defcustom comp-async-report-warnings-errors t - "Report warnings and errors from native asynchronous compilation." + "Whether to report warnings and errors from asynchronous native compilation." :type 'boolean) (defcustom comp-async-query-on-exit nil - "Exiting Emacs, query the user if async compilation process is running." + "Whether to query the user about killing async compilations when exiting. +If this is non-nil, Emacs will ask for confirmation to exit and kill the +asynchronous native compilations if any are running. If nil, when you +exit Emacs, it will silently kill those asynchronous compilations even +if `confirm-kill-processes' is non-nil." :type 'boolean) (defcustom comp-native-driver-options nil commit 54df918ad1e19513768bc27cb3e0a78856d30135 Author: Andrea Corallo Date: Fri Feb 26 08:49:58 2021 +0100 * Add `comp-async-query-on-exit' customize. * lisp/emacs-lisp/comp.el (comp-async-query-on-exit): New customize. (comp-run-async-workers): Make use of. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index ddf3f049e8..6af4ee2beb 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -127,6 +127,10 @@ Usable to modify the compiler environment." "Report warnings and errors from native asynchronous compilation." :type 'boolean) +(defcustom comp-async-query-on-exit nil + "Exiting Emacs, query the user if async compilation process is running." + :type 'boolean) + (defcustom comp-native-driver-options nil "Options passed verbatim to the native compiler's backend driver. Note that not all options are meaningful; typically only the options @@ -3928,7 +3932,8 @@ display a message." (native-elisp-load (comp-el-to-eln-filename source-file1) (eq load1 'late))) - (comp-run-async-workers))))) + (comp-run-async-workers)) + :noquery (not comp-async-query-on-exit)))) (puthash source-file process comp-async-compilations)) when (>= (comp-async-runnings) (comp-effective-async-max-jobs)) do (cl-return))) commit 3a31fca5dba41e9905b1293fc73dd1d44abc3138 Author: Andrea Corallo Date: Thu Feb 25 20:46:27 2021 +0100 * Fix some comp-vec logic * lisp/emacs-lisp/comp.el (comp-vec-length, comp-vec-append) (comp-vec-prepend): Fix logic. (comp-vec-aref): Fix indentation. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 40c1dfd831..ddf3f049e8 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -617,7 +617,7 @@ Useful to hook into pass checkers.") (defsubst comp-vec-length (vec) "Return the number of elements of VEC." - (+ (comp-vec-beg vec) (comp-vec-end vec))) + (- (comp-vec-end vec) (comp-vec-beg vec))) (defsubst comp-vec--verify-idx (vec idx) "Check idx is in bounds for VEC." @@ -628,21 +628,21 @@ Useful to hook into pass checkers.") "Return the element of VEC at index IDX." (declare (gv-setter (lambda (val) `(comp-vec--verify-idx ,vec ,idx) - `(puthash ,idx ,val (comp-vec-data ,vec))))) + `(puthash ,idx ,val (comp-vec-data ,vec))))) (comp-vec--verify-idx vec idx) (gethash idx (comp-vec-data vec))) (defsubst comp-vec-append (vec elt) "Append ELT into VEC. ELT is returned." - (puthash (comp-vec-end vec) elt (comp-vec-aref vec)) + (puthash (comp-vec-end vec) elt (comp-vec-data vec)) (cl-incf (comp-vec-end vec)) elt) (defsubst comp-vec-prepend (vec elt) "Prepend ELT into VEC. ELT is returned." - (puthash (comp-vec-beg vec) elt (comp-vec-aref vec)) + (puthash (1- (comp-vec-beg vec)) elt (comp-vec-data vec)) (cl-decf (comp-vec-beg vec)) elt) commit 9ae48ae714b03e102957a1e9f9d6430f82c7adaa Author: Andrea Corallo Date: Thu Feb 25 20:25:05 2021 +0100 * Fix two docstrings in comp.el * lisp/emacs-lisp/comp.el (comp-new-frame, comp-maybe-add-vmvar): Fix docstring. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 9ed92d720c..40c1dfd831 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1470,7 +1470,7 @@ STACK-OFF is the index of the first slot frame involved." mvar)) (defun comp-new-frame (size vsize &optional ssa) - "Return a clean frame of meta variables of size SIZE. + "Return a clean frame of meta variables of size SIZE and VSIZE. If SSA non-nil populate it of m-var in ssa form." (cl-loop with v = (make-comp-vec :beg (- vsize) :end size) for i from (- vsize) below size @@ -2324,7 +2324,7 @@ The assume is emitted at the beginning of the block BB." (setf (comp-func-ssa-status comp-func) 'dirty))) (defun comp-maybe-add-vmvar (op cmp-res insns-seq) - "If CMP-RES is clobbering OP emit a new constrained MVAR and return it. + "If CMP-RES is clobbering OP emit a new constrained mvar and return it. Return OP otherwise." (if-let ((match (eql (comp-mvar-slot op) (comp-mvar-slot cmp-res))) (new-mvar (make-comp-mvar commit 0ee1a16769bfc8d3e6205e8d8dabc3be34df48b4 Author: Andrea Corallo Date: Wed Feb 24 00:03:21 2021 +0100 Fix async compilation and paramenter naming * lisp/emacs-lisp/comp.el (native--compile-async) (native-compile-async): Fix broken parameter renaming. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index f18f8e3772..9ed92d720c 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -4011,7 +4011,7 @@ LOAD and SELECTOR work as described in `native--compile-async'." (defun native--compile-async (files &optional recursively load selector) "Compile FILES asynchronously. -FILES is one path or a list of files to files or directories. +FILES is one filename or a list of filenames or directories. If optional argument RECURSIVELY is non-nil, recurse into subdirectories of given directories. @@ -4042,18 +4042,18 @@ bytecode definition was not changed in the meanwhile)." (error "LOAD must be nil, t or 'late")) (unless (listp files) (setf files (list files))) - (let (files) + (let (file-list) (dolist (path files) (cond ((file-directory-p path) (dolist (file (if recursively (directory-files-recursively path comp-valid-source-re) (directory-files path t comp-valid-source-re))) - (push file files))) - ((file-exists-p path) (push path files)) + (push file file-list))) + ((file-exists-p path) (push path file-list)) (t (signal 'native-compiler-error (list "Path not a file nor directory" path))))) - (dolist (file files) + (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 ;; compilation, so update `comp-files-queue' to reflect that. @@ -4125,7 +4125,7 @@ environment variable 'NATIVE_DISABLED' is set byte compile only." ;;;###autoload (defun native-compile-async (files &optional recursively load selector) "Compile FILES asynchronously. -FILES is one path or a list of files to files or directories. +FILES is one file or a list of filenames or directories. If optional argument RECURSIVELY is non-nil, recurse into subdirectories of given directories. commit bddd7a2d1376d8ee7a318fc837aaaa98b9d9ce49 Author: Andrea Corallo Date: Tue Feb 23 14:35:11 2021 +0100 Do not emit assumptions referencing clobbered mvars (bug#46670) * lisp/emacs-lisp/comp.el (comp-func): Add `vframe-size' slot. (comp-new-frame): Add `vsize' parameter. (comp-limplify-top-level, comp-limplify-function): Update for new `comp-new-frame'. (comp-maybe-add-vmvar): New function. (comp-add-cond-cstrs): Logic update to emit assumptions not referencing clobbered variables. (comp-place-phis, comp-ssa, comp-ssa-rename-insn) (comp-ssa-rename): Update rename logic to rename also negative slots. (comp-fwprop-insn): Update to handle `(assume mvar mvar)' form. * test/src/comp-tests.el (46670-1): Add testcase. * test/src/comp-test-funcs.el (comp-test-46670-1-f) (comp-test-46670-2-f): New functions. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index b6451d591c..f18f8e3772 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -809,6 +809,7 @@ non local exit (ends with an `unreachable' insn).")) Once in SSA form this *must* be set to 'dirty' every time the topology of the CFG is mutated by a pass.") (frame-size nil :type integer) + (vframe-size 0 :type integer) (blocks (make-hash-table :test #'eq) :type hash-table :documentation "Basic block symbol -> basic block.") (lap-block (make-hash-table :test #'equal) :type hash-table @@ -1468,11 +1469,11 @@ STACK-OFF is the index of the first slot frame involved." (setf (comp-mvar-typeset mvar) (list type))) mvar)) -(defun comp-new-frame (size &optional ssa) +(defun comp-new-frame (size vsize &optional ssa) "Return a clean frame of meta variables of size SIZE. If SSA non-nil populate it of m-var in ssa form." - (cl-loop with v = (make-comp-vec) - for i below size + (cl-loop with v = (make-comp-vec :beg (- vsize) :end size) + for i from (- vsize) below size for mvar = (if ssa (make-comp-ssa-mvar :slot i) (make-comp-mvar :slot i)) @@ -2116,7 +2117,7 @@ into the C code forwarding the compilation unit." (comp-func func) (comp-pass (make-comp-limplify :curr-block (make--comp-block-lap -1 0 'top-level) - :frame (comp-new-frame 1)))) + :frame (comp-new-frame 1 0)))) (comp-make-curr-block 'entry (comp-sp)) (comp-emit-annotation (if for-late-load "Late top level" @@ -2177,7 +2178,7 @@ into the C code forwarding the compilation unit." (let* ((frame-size (comp-func-frame-size func)) (comp-func func) (comp-pass (make-comp-limplify - :frame (comp-new-frame frame-size)))) + :frame (comp-new-frame frame-size 0)))) (comp-fill-label-h) ;; Prologue (comp-make-curr-block 'entry (comp-sp)) @@ -2322,6 +2323,18 @@ The assume is emitted at the beginning of the block BB." (_ (cl-assert nil))) (setf (comp-func-ssa-status comp-func) 'dirty))) +(defun comp-maybe-add-vmvar (op cmp-res insns-seq) + "If CMP-RES is clobbering OP emit a new constrained MVAR and return it. +Return OP otherwise." + (if-let ((match (eql (comp-mvar-slot op) (comp-mvar-slot cmp-res))) + (new-mvar (make-comp-mvar + :slot + (- (cl-incf (comp-func-vframe-size comp-func)))))) + (progn + (push `(assume ,new-mvar ,op) (cdr insns-seq)) + new-mvar) + op)) + (defun comp-add-new-block-between (bb-symbol bb-a bb-b) "Create a new basic-block named BB-SYMBOL and add it between BB-A and BB-B." (cl-loop @@ -2427,6 +2440,7 @@ TARGET-BB-SYM is the symbol name of the target block." do (cl-loop named in-the-basic-block + with prev-insns-seq for insns-seq on (comp-block-insns b) do (pcase insns-seq @@ -2452,10 +2466,14 @@ TARGET-BB-SYM is the symbol name of the target block." (let ((block-target (comp-add-cond-cstrs-target-block b branch-target))) (setf (car branch-target-cell) (comp-block-name block-target)) (when (comp-mvar-used-p target-mvar1) - (comp-emit-assume kind target-mvar1 op2 block-target negated)) + (comp-emit-assume kind target-mvar1 + (comp-maybe-add-vmvar op2 cmp-res prev-insns-seq) + block-target negated)) (when (comp-mvar-used-p target-mvar2) (comp-emit-assume (comp-reverse-cmp-fun kind) - target-mvar2 op1 block-target negated))) + target-mvar2 + (comp-maybe-add-vmvar op1 cmp-res prev-insns-seq) + block-target negated))) finally (cl-return-from in-the-basic-block))) (`((set ,(and (pred comp-mvar-p) cmp-res) (,(pred comp-call-op-p) @@ -2493,7 +2511,8 @@ TARGET-BB-SYM is the symbol name of the target block." (let ((block-target (comp-add-cond-cstrs-target-block b branch-target))) (setf (car branch-target-cell) (comp-block-name block-target)) (comp-emit-assume 'and target-mvar cstr block-target negated)) - finally (cl-return-from in-the-basic-block))))))) + finally (cl-return-from in-the-basic-block)))) + (setf prev-insns-seq insns-seq)))) (defsubst comp-insert-insn (insn insn-cell) "Insert INSN as second insn of INSN-CELL." @@ -2816,7 +2835,8 @@ blocks." (eq op 'fetch-handler)) return t))) - (cl-loop for i from 0 below (comp-func-frame-size comp-func) ; FIXME + (cl-loop for i from (- (comp-func-vframe-size comp-func)) + below (comp-func-frame-size comp-func) ;; List of blocks with a definition of mvar i for defs-v = (cl-loop with blocks = (comp-func-blocks comp-func) for b being each hash-value of blocks @@ -2854,40 +2874,44 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non-nil." (cl-defstruct (comp-ssa (:copier nil)) "Support structure used while SSA renaming." - (frame (comp-new-frame (comp-func-frame-size comp-func) t) :type comp-vec + (frame (comp-new-frame (comp-func-frame-size comp-func) + (comp-func-vframe-size comp-func) t) + :type comp-vec :documentation "`comp-vec' of m-vars.")) (defun comp-ssa-rename-insn (insn frame) - (dotimes (slot-n (comp-func-frame-size comp-func)) - (cl-flet ((targetp (x) - ;; Ret t if x is an mvar and target the correct slot number. - (and (comp-mvar-p x) - (eql slot-n (comp-mvar-slot x)))) - (new-lvalue () - ;; If is an assignment make a new mvar and put it as l-value. - (let ((mvar (make-comp-ssa-mvar :slot slot-n))) - (setf (comp-vec-aref frame slot-n) mvar - (cadr insn) mvar)))) - (pcase insn - (`(,(pred comp-assign-op-p) ,(pred targetp) . ,_) - (let ((mvar (comp-vec-aref frame slot-n))) - (setf (cddr insn) (cl-nsubst-if mvar #'targetp (cddr insn)))) - (new-lvalue)) - (`(fetch-handler . ,_) - ;; Clobber all no matter what! - (setf (comp-vec-aref frame slot-n) (make-comp-ssa-mvar :slot slot-n))) - (`(phi ,n) - (when (equal n slot-n) - (new-lvalue))) - (_ - (let ((mvar (comp-vec-aref frame slot-n))) - (setcdr insn (cl-nsubst-if mvar #'targetp (cdr insn))))))))) + (cl-loop + for slot-n from (- (comp-func-vframe-size comp-func)) + below (comp-func-frame-size comp-func) + do + (cl-flet ((targetp (x) + ;; Ret t if x is an mvar and target the correct slot number. + (and (comp-mvar-p x) + (eql slot-n (comp-mvar-slot x)))) + (new-lvalue () + ;; If is an assignment make a new mvar and put it as l-value. + (let ((mvar (make-comp-ssa-mvar :slot slot-n))) + (setf (comp-vec-aref frame slot-n) mvar + (cadr insn) mvar)))) + (pcase insn + (`(,(pred comp-assign-op-p) ,(pred targetp) . ,_) + (let ((mvar (comp-vec-aref frame slot-n))) + (setf (cddr insn) (cl-nsubst-if mvar #'targetp (cddr insn)))) + (new-lvalue)) + (`(fetch-handler . ,_) + ;; Clobber all no matter what! + (setf (comp-vec-aref frame slot-n) (make-comp-ssa-mvar :slot slot-n))) + (`(phi ,n) + (when (equal n slot-n) + (new-lvalue))) + (_ + (let ((mvar (comp-vec-aref frame slot-n))) + (setcdr insn (cl-nsubst-if mvar #'targetp (cdr insn))))))))) (defun comp-ssa-rename () "Entry point to rename into SSA within the current function." (comp-log "Renaming\n" 2) - (let ((frame-size (comp-func-frame-size comp-func)) - (visited (make-hash-table))) + (let ((visited (make-hash-table))) (cl-labels ((ssa-rename-rec (bb in-frame) (unless (gethash bb visited) (puthash bb t visited) @@ -2903,7 +2927,9 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non-nil." do (ssa-rename-rec child (comp-vec-copy in-frame))))))) (ssa-rename-rec (gethash 'entry (comp-func-blocks comp-func)) - (comp-new-frame frame-size t))))) + (comp-new-frame (comp-func-frame-size comp-func) + (comp-func-vframe-size comp-func) + t))))) (defun comp-finalize-phis () "Fixup r-values into phis in all basic blocks." @@ -3094,6 +3120,8 @@ Fold the call in case." (comp-fwprop-call insn lval f args))) (_ (comp-mvar-propagate lval rval)))) + (`(assume ,lval ,(and (pred comp-mvar-p) rval)) + (comp-mvar-propagate lval rval)) (`(assume ,lval (,kind . ,operands)) (cl-case kind (and diff --git a/test/src/comp-test-funcs.el b/test/src/comp-test-funcs.el index 694d9d426d..5bae743d15 100644 --- a/test/src/comp-test-funcs.el +++ b/test/src/comp-test-funcs.el @@ -478,6 +478,13 @@ (eq family 'unspecified)) family))) +(defun comp-test-46670-1-f (x) + "foo") + +(defun comp-test-46670-2-f (s) + (and (equal (comp-test-46670-1-f (length s)) s) + s)) + ;;;;;;;;;;;;;;;;;;;; ;; Tromey's tests ;; diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index f7b5a6bbb4..fa84ffbc0b 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -497,6 +497,12 @@ https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-03/msg00914.html." (load (native-compile (concat comp-test-directory "comp-test-45603.el"))) (should (fboundp #'comp-test-45603--file-local-name))) +(comp-deftest 46670-1 () + "" + (should (string= (comp-test-46670-2-f "foo") "foo")) + (should (equal (subr-type (symbol-function #'comp-test-46670-2-f)) + '(function (t) (or null sequence))))) + ;;;;;;;;;;;;;;;;;;;;; ;; Tromey's tests. ;; commit 89e9b051809d85d50d67c52d0388f8fffee8ba32 Author: Andrea Corallo Date: Mon Feb 22 17:28:19 2021 +0100 * Move ssa rename from vector to comp-vec * lisp/emacs-lisp/comp.el (comp-block): Updated `final-frame' slot type. (comp-limplify): Updated `frame' slot type. (comp-slot-n, comp-new-frame, comp-place-phis, comp-ssa) (comp-ssa-rename-insn, comp-ssa-rename, comp-finalize-phis): Use `comp-vec'. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 267b67f99e..b6451d591c 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -733,7 +733,7 @@ This is typically for top-level forms other than defun.") :documentation "Dominance frontier set. Block-name -> block") (post-num nil :type (or null number) :documentation "Post order number.") - (final-frame nil :type (or null vector) + (final-frame nil :type (or null comp-vec) :documentation "This is a copy of the frame when leaving the block. Is in use to help the SSA rename pass.")) @@ -1357,7 +1357,7 @@ If INPUT is a string this is the filename to be compiled." (cl-defstruct (comp-limplify (:copier nil)) "Support structure used during function limplification." - (frame nil :type vector + (frame nil :type (or null comp-vec) :documentation "Meta-stack used to flat LAP.") (curr-block nil :type comp-block :documentation "Current block being limplified.") @@ -1406,7 +1406,7 @@ Restore the original value afterwards." (defsubst comp-slot-n (n) "Slot N into the meta-stack." - (aref (comp-limplify-frame comp-pass) n)) + (comp-vec-aref (comp-limplify-frame comp-pass) n)) (defsubst comp-slot () "Current slot into the meta-stack pointed by sp." @@ -1471,12 +1471,12 @@ STACK-OFF is the index of the first slot frame involved." (defun comp-new-frame (size &optional ssa) "Return a clean frame of meta variables of size SIZE. If SSA non-nil populate it of m-var in ssa form." - (cl-loop with v = (make-vector size nil) + (cl-loop with v = (make-comp-vec) for i below size for mvar = (if ssa (make-comp-ssa-mvar :slot i) (make-comp-mvar :slot i)) - do (aset v i mvar) + do (setf (comp-vec-aref v i) mvar) finally return v)) (defun comp-emit (insn) @@ -2816,7 +2816,7 @@ blocks." (eq op 'fetch-handler)) return t))) - (cl-loop for i from 0 below (comp-func-frame-size comp-func) + (cl-loop for i from 0 below (comp-func-frame-size comp-func) ; FIXME ;; List of blocks with a definition of mvar i for defs-v = (cl-loop with blocks = (comp-func-blocks comp-func) for b being each hash-value of blocks @@ -2854,8 +2854,8 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non-nil." (cl-defstruct (comp-ssa (:copier nil)) "Support structure used while SSA renaming." - (frame (comp-new-frame (comp-func-frame-size comp-func) t) :type vector - :documentation "Vector of m-vars.")) + (frame (comp-new-frame (comp-func-frame-size comp-func) t) :type comp-vec + :documentation "`comp-vec' of m-vars.")) (defun comp-ssa-rename-insn (insn frame) (dotimes (slot-n (comp-func-frame-size comp-func)) @@ -2866,21 +2866,21 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non-nil." (new-lvalue () ;; If is an assignment make a new mvar and put it as l-value. (let ((mvar (make-comp-ssa-mvar :slot slot-n))) - (setf (aref frame slot-n) mvar + (setf (comp-vec-aref frame slot-n) mvar (cadr insn) mvar)))) (pcase insn (`(,(pred comp-assign-op-p) ,(pred targetp) . ,_) - (let ((mvar (aref frame slot-n))) + (let ((mvar (comp-vec-aref frame slot-n))) (setf (cddr insn) (cl-nsubst-if mvar #'targetp (cddr insn)))) (new-lvalue)) (`(fetch-handler . ,_) ;; Clobber all no matter what! - (setf (aref frame slot-n) (make-comp-ssa-mvar :slot slot-n))) + (setf (comp-vec-aref frame slot-n) (make-comp-ssa-mvar :slot slot-n))) (`(phi ,n) (when (equal n slot-n) (new-lvalue))) (_ - (let ((mvar (aref frame slot-n))) + (let ((mvar (comp-vec-aref frame slot-n))) (setcdr insn (cl-nsubst-if mvar #'targetp (cdr insn))))))))) (defun comp-ssa-rename () @@ -2900,7 +2900,7 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non-nil." for ed in out-edges for child = (comp-edge-dst ed) ;; Provide a copy of the same frame to all children. - do (ssa-rename-rec child (copy-sequence in-frame))))))) + do (ssa-rename-rec child (comp-vec-copy in-frame))))))) (ssa-rename-rec (gethash 'entry (comp-func-blocks comp-func)) (comp-new-frame frame-size t))))) @@ -2914,7 +2914,7 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non-nil." for e in (comp-block-in-edges b) for b = (comp-edge-src e) for in-frame = (comp-block-final-frame b) - collect (list (aref in-frame slot-n) + collect (list (comp-vec-aref in-frame slot-n) (comp-block-name b)))))) (cl-loop for b being each hash-value of (comp-func-blocks comp-func) commit ec88bdba6fea4af18e5662d4d4a4339ebc1f81ff Author: Andrea Corallo Date: Mon Feb 22 15:07:00 2021 +0100 * Add a simple growable vector like type * lisp/emacs-lisp/comp.el (comp-vec): Define struct. (comp-vec-copy, comp-vec-length, comp-vec--verify-idx) (comp-vec-aref, comp-vec-append, comp-vec-prepend): New functions. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index e2b1d04bc2..267b67f99e 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -600,6 +600,53 @@ Useful to hook into pass checkers.") (define-error 'native-compiler-error-empty-byte "empty byte compiler output" 'native-compiler-error) + + +(cl-defstruct (comp-vec (:copier nil)) + "A re-sizable vector like object." + (data (make-hash-table :test #'eql) :type hash-table + :documentation "Payload data.") + (beg 0 :type integer) + (end 0 :type natnum)) + +(defsubst comp-vec-copy (vec) + "Return a copy of VEC." + (make-comp-vec :data (copy-hash-table (comp-vec-data vec)) + :beg (comp-vec-beg vec) + :end (comp-vec-end vec))) + +(defsubst comp-vec-length (vec) + "Return the number of elements of VEC." + (+ (comp-vec-beg vec) (comp-vec-end vec))) + +(defsubst comp-vec--verify-idx (vec idx) + "Check idx is in bounds for VEC." + (cl-assert (and (< idx (comp-vec-end vec)) + (>= idx (comp-vec-beg vec))))) + +(defsubst comp-vec-aref (vec idx) + "Return the element of VEC at index IDX." + (declare (gv-setter (lambda (val) + `(comp-vec--verify-idx ,vec ,idx) + `(puthash ,idx ,val (comp-vec-data ,vec))))) + (comp-vec--verify-idx vec idx) + (gethash idx (comp-vec-data vec))) + +(defsubst comp-vec-append (vec elt) + "Append ELT into VEC. +ELT is returned." + (puthash (comp-vec-end vec) elt (comp-vec-aref vec)) + (cl-incf (comp-vec-end vec)) + elt) + +(defsubst comp-vec-prepend (vec elt) + "Prepend ELT into VEC. +ELT is returned." + (puthash (comp-vec-beg vec) elt (comp-vec-aref vec)) + (cl-decf (comp-vec-beg vec)) + elt) + + (eval-when-compile (defconst comp-op-stack-info @@ -2772,9 +2819,9 @@ blocks." (cl-loop for i from 0 below (comp-func-frame-size comp-func) ;; List of blocks with a definition of mvar i for defs-v = (cl-loop with blocks = (comp-func-blocks comp-func) - for b being each hash-value of blocks - when (slot-assigned-p i b) - collect b) + for b being each hash-value of blocks + when (slot-assigned-p i b) + collect b) ;; Set of basic blocks where phi is added. for f = () ;; Worklist, set of basic blocks that contain definitions of v. commit cadb902aa8136d9eff8bb0df39daed840c00e1b6 Author: Andrea Corallo Date: Mon Feb 22 21:01:44 2021 +0100 Revert "* configure.ac: Rename configure nativecomp flags..." This reverts commit f6c5f0dd5c8167b6f8f724f42632a4b8808efe7a. Reason for this is that I overlooked few other suggestions and this change has to be discussed before a final decision is taken. diff --git a/configure.ac b/configure.ac index 1771171f66..fe0dc921dc 100644 --- a/configure.ac +++ b/configure.ac @@ -484,7 +484,7 @@ OPTION_DEFAULT_ON([gnutls],[don't use -lgnutls for SSL/TLS support]) 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([native-comp],[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)])], @@ -3786,7 +3786,7 @@ AC_DEFUN([libgccjit_not_found], [ AC_MSG_ERROR([elisp native compiler requested but libgccjit not found. Please try installing libgccjit or similar package. If you are sure you want Emacs compiled without elisp native compiler, pass - --without-native-comp + --without-nativecomp to configure.])]) AC_DEFUN([libgccjit_dev_not_found], [ @@ -3808,7 +3808,7 @@ Here instructions on how to compile and install libgccjit from source: HAVE_NATIVE_COMP=no LIBGCCJIT_LIB= -if test "${with_native_comp}" != "no"; then +if test "${with_nativecomp}" != "no"; then if test "${HAVE_PDUMPER}" = no; then AC_MSG_ERROR(['--with-nativecomp' requires '--with-dumping=pdumper']) fi commit 28ce6f980ff9dc022550933f840ab5c8469cc9d1 Author: Andrea Corallo Date: Mon Feb 22 15:17:07 2021 +0100 * Some clean-up in comp.el * lisp/emacs-lisp/comp.el (comp-func): Remove 'array-h'. (comp-spill-lap-function, comp-intern-func-in-ctxt) (comp-spill-lap-function, comp-addr-to-bb-name): Update accordingly. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 677e6a7b8d..e2b1d04bc2 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -774,8 +774,6 @@ CFG is mutated by a pass.") :documentation "Generates edges numbers.") (has-non-local nil :type boolean :documentation "t if non local jumps are present.") - (array-h (make-hash-table) :type hash-table - :documentation "array idx -> array length.") (speed nil :type number :documentation "Optimization level (see `comp-speed').") (pure nil :type boolean @@ -1188,8 +1186,6 @@ clashes." (setf (comp-ctxt-top-level-forms comp-ctxt) (list (make-byte-to-native-func-def :name function-name :c-name c-name))) - ;; Create the default array. - (puthash 0 (comp-func-frame-size func) (comp-func-array-h func)) (comp-add-func-to-ctxt func)))) (cl-defmethod comp-spill-lap-function ((form list)) @@ -1227,8 +1223,6 @@ clashes." (comp-ctxt-top-level-forms comp-ctxt) (list (make-byte-to-native-func-def :name '--anonymous-lambda :c-name c-name))) - ;; Create the default array. - (puthash 0 (comp-func-frame-size func) (comp-func-array-h func)) (comp-add-func-to-ctxt func)))) (defun comp-intern-func-in-ctxt (_ obj) @@ -1265,8 +1259,6 @@ clashes." (setf (byte-to-native-func-def-c-name top-l-form) c-name)) (unless name (puthash byte-func func (comp-ctxt-byte-func-to-func-h comp-ctxt))) - ;; Create the default array. - (puthash 0 (comp-func-frame-size func) (comp-func-array-h func)) (comp-add-func-to-ctxt func) (comp-log (format "Function %s:\n" name) 1) (comp-log lap 1 t)))) @@ -2090,7 +2082,6 @@ into the C code forwarding the compilation unit." (mapc (lambda (x) (comp-emit-for-top-level x for-late-load)) (comp-ctxt-top-level-forms comp-ctxt)) (comp-emit `(return ,(make-comp-mvar :slot 1))) - (puthash 0 (comp-func-frame-size func) (comp-func-array-h func)) (comp-limplify-finalize-function func))) (defun comp-addr-to-bb-name (addr) commit f6c5f0dd5c8167b6f8f724f42632a4b8808efe7a Author: Andrea Corallo Date: Mon Feb 22 14:39:04 2021 +0100 * configure.ac: Rename configure nativecomp flags into --with-native-comp. Configure now with '--with-native-comp'! diff --git a/configure.ac b/configure.ac index fe0dc921dc..1771171f66 100644 --- a/configure.ac +++ b/configure.ac @@ -484,7 +484,7 @@ OPTION_DEFAULT_ON([gnutls],[don't use -lgnutls for SSL/TLS support]) 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],[compile with Emacs Lisp native compiler support]) +OPTION_DEFAULT_OFF([native-comp],[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)])], @@ -3786,7 +3786,7 @@ AC_DEFUN([libgccjit_not_found], [ AC_MSG_ERROR([elisp native compiler requested but libgccjit not found. Please try installing libgccjit or similar package. If you are sure you want Emacs compiled without elisp native compiler, pass - --without-nativecomp + --without-native-comp to configure.])]) AC_DEFUN([libgccjit_dev_not_found], [ @@ -3808,7 +3808,7 @@ Here instructions on how to compile and install libgccjit from source: HAVE_NATIVE_COMP=no LIBGCCJIT_LIB= -if test "${with_nativecomp}" != "no"; then +if test "${with_native_comp}" != "no"; then if test "${HAVE_PDUMPER}" = no; then AC_MSG_ERROR(['--with-nativecomp' requires '--with-dumping=pdumper']) fi commit 81b1013555363be1513a13f5f07ee50041969dfa Author: Andrea Corallo Date: Mon Feb 22 14:31:23 2021 +0100 * Don't use paths to indicate filenames * lisp/emacs-lisp/comp.el (native--compile-async) (native-compile-async): Replace `paths' argname with `files'. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 60c040926e..677e6a7b8d 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -3943,9 +3943,9 @@ LOAD and SELECTOR work as described in `native--compile-async'." (string-match-p re file)) comp-deferred-compilation-deny-list)))) -(defun native--compile-async (paths &optional recursively load selector) - "Compile PATHS asynchronously. -PATHS is one path or a list of paths to files or directories. +(defun native--compile-async (files &optional recursively load selector) + "Compile FILES asynchronously. +FILES is one path or a list of files to files or directories. If optional argument RECURSIVELY is non-nil, recurse into subdirectories of given directories. @@ -3974,10 +3974,10 @@ bytecode definition was not changed in the meanwhile)." (comp-ensure-native-compiler) (unless (member load '(nil t late)) (error "LOAD must be nil, t or 'late")) - (unless (listp paths) - (setf paths (list paths))) + (unless (listp files) + (setf files (list files))) (let (files) - (dolist (path paths) + (dolist (path files) (cond ((file-directory-p path) (dolist (file (if recursively (directory-files-recursively @@ -4057,9 +4057,9 @@ environment variable 'NATIVE_DISABLED' is set byte compile only." (rename-file tempfile target-file t)))))) ;;;###autoload -(defun native-compile-async (paths &optional recursively load selector) - "Compile PATHS asynchronously. -PATHS is one path or a list of paths to files or directories. +(defun native-compile-async (files &optional recursively load selector) + "Compile FILES asynchronously. +FILES is one path or a list of files to files or directories. If optional argument RECURSIVELY is non-nil, recurse into subdirectories of given directories. @@ -4077,7 +4077,7 @@ The variable `comp-async-jobs-number' specifies the number of (commands) to run simultaneously." ;; Normalize: we only want to pass t or nil, never e.g. `late'. (let ((load (not (not load)))) - (native--compile-async paths recursively load selector))) + (native--compile-async files recursively load selector))) (provide 'comp) commit d6227f6edcff7be05469e99da4ce541bfc474c3d Author: Andrea Corallo Date: Mon Feb 22 13:58:30 2021 +0100 * Fix union constraint for mixed pos/neg constraints * lisp/emacs-lisp/comp-cstr.el (comp-cstr-union-1-no-mem): Fix neg type shadowing pos values. * test/lisp/emacs-lisp/comp-cstr-tests.el (comp-cstr-typespec-tests-alist): Add testcase. * test/src/comp-tests.el (comp-tests-type-spec-tests): Fix testcase. diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el index 3c00b68d0f..c294c53b6b 100644 --- a/lisp/emacs-lisp/comp-cstr.el +++ b/lisp/emacs-lisp/comp-cstr.el @@ -597,6 +597,12 @@ DST is returned." (valset pos))) ;; Pos is a superset of neg. (give-up)) + ((cl-some (lambda (x) + (cl-some (lambda (y) + (comp-subtype-p y x)) + (mapcar #'type-of (valset pos)))) + (typeset neg)) + (give-up)) (t ;; pos is a subset or eq to neg (setf (valset neg) diff --git a/test/lisp/emacs-lisp/comp-cstr-tests.el b/test/lisp/emacs-lisp/comp-cstr-tests.el index b4db54666c..f2d9bf583e 100644 --- a/test/lisp/emacs-lisp/comp-cstr-tests.el +++ b/test/lisp/emacs-lisp/comp-cstr-tests.el @@ -211,7 +211,9 @@ ;; 85 ((or (not string) t) . t) ;; 86 - ((or (not vector) sequence) . sequence)) + ((or (not vector) sequence) . sequence) + ;; 87 + ((or (not symbol) null) . t)) "Alist type specifier -> expected type specifier.")) (defmacro comp-cstr-synthesize-tests () diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 08c1889441..f7b5a6bbb4 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -1185,7 +1185,7 @@ Return a list of results." ((defun comp-tests-ret-type-spec-f (x) (unless (symbolp x) x)) - (not symbol)) + t) ;; 55 ((defun comp-tests-ret-type-spec-f (x) commit da4da88c76465e30ce974383b182f191553b470a Author: Andrea Corallo Date: Sun Feb 21 22:20:59 2021 +0100 * lisp/emacs-lisp/comp.el (comp-spill-lap): Fix doc string. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 4036080976..60c040926e 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1306,7 +1306,7 @@ clashes." (defun comp-spill-lap (input) "Byte-compile and spill the LAP representation for INPUT. If INPUT is a symbol this is the function-name to be compiled. -If INPUT is a string this is the file path to be compiled." +If INPUT is a string this is the filename to be compiled." (let ((byte-native-compiling t) (byte-to-native-lambdas-h (make-hash-table :test #'eq)) (byte-to-native-top-level-forms ()) commit cf1e8e792f60949e09e3ad4c53fb61b0b7628229 Merge: 39792cf629 d0c47652e5 Author: Andrea Corallo Date: Sun Feb 21 22:08:01 2021 +0100 Merge remote-tracking branch 'savannah/master' into HEAD commit 39792cf62987ecc1a772f6a2027d6b32c70e8312 Author: Andrea Corallo Date: Tue Feb 16 22:54:49 2021 +0100 * Work around bug#46495 (GCC PR99126) * src/comp.c (gcc_jit_context_add_command_line_option): Import for dynamic load. (Fcomp__compile_ctxt_to_file): Disable GCC "isolate-paths" on GCC 10. diff --git a/src/comp.c b/src/comp.c index 24c40f7c3e..a8b8ef95fa 100644 --- a/src/comp.c +++ b/src/comp.c @@ -56,6 +56,7 @@ along with GNU Emacs. If not, see . */ #undef gcc_jit_block_end_with_return #undef gcc_jit_block_end_with_void_return #undef gcc_jit_context_acquire +#undef gcc_jit_context_add_command_line_option #undef gcc_jit_context_add_driver_option #undef gcc_jit_context_compile_to_file #undef gcc_jit_context_dump_reproducer_to_file @@ -124,6 +125,8 @@ DEF_DLL_FN (const char *, gcc_jit_context_get_first_error, DEF_DLL_FN (gcc_jit_block *, gcc_jit_function_new_block, (gcc_jit_function *func, const char *name)); DEF_DLL_FN (gcc_jit_context *, gcc_jit_context_acquire, (void)); +DEF_DLL_FN (void, gcc_jit_context_add_command_line_option, + (gcc_jit_context *ctxt, const char *optname)); DEF_DLL_FN (void, gcc_jit_context_add_driver_option, (gcc_jit_context *ctxt, const char *optname)); DEF_DLL_FN (gcc_jit_field *, gcc_jit_context_new_field, @@ -312,6 +315,7 @@ init_gccjit_functions (void) LOAD_DLL_FN (library, gcc_jit_struct_set_fields); LOAD_DLL_FN (library, gcc_jit_type_get_const); LOAD_DLL_FN (library, gcc_jit_type_get_pointer); + LOAD_DLL_FN_OPT (library, gcc_jit_context_add_command_line_option); LOAD_DLL_FN_OPT (library, gcc_jit_context_add_driver_option); LOAD_DLL_FN_OPT (library, gcc_jit_global_set_initializer); LOAD_DLL_FN_OPT (library, gcc_jit_version_major); @@ -330,6 +334,7 @@ init_gccjit_functions (void) #define gcc_jit_block_end_with_return fn_gcc_jit_block_end_with_return #define gcc_jit_block_end_with_void_return fn_gcc_jit_block_end_with_void_return #define gcc_jit_context_acquire fn_gcc_jit_context_acquire +#define gcc_jit_context_add_command_line_option fn_gcc_jit_context_add_command_line_option #define gcc_jit_context_add_driver_option fn_gcc_jit_context_add_driver_option #define gcc_jit_context_compile_to_file fn_gcc_jit_context_compile_to_file #define gcc_jit_context_dump_reproducer_to_file fn_gcc_jit_context_dump_reproducer_to_file @@ -4375,6 +4380,16 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, if (!EQ (HASH_VALUE (func_h, i), Qunbound)) compile_function (HASH_VALUE (func_h, i)); + /* Work around bug#46495 (GCC PR99126). */ +#if defined (WIDE_EMACS_INT) \ + && (defined (LIBGCCJIT_HAVE_gcc_jit_context_add_command_line_option) \ + || defined (WINDOWSNT)) + Lisp_Object version = Fcomp_libgccjit_version (); + if (!NILP (version) && XFIXNUM (XCAR (version)) == 10) + gcc_jit_context_add_command_line_option (comp.ctxt, + "-fdisable-tree-isolate-paths"); +#endif + add_driver_options (); if (comp.debug) commit 92fe7a91f4c88bb8661d4f1f15739849ddc01754 Author: Andrea Corallo Date: Fri Feb 19 16:14:31 2021 +0100 * Remove unnecessary function 'emit_rvalue_from_unsigned_long_long' * src/comp.c (emit_rvalue_from_unsigned_long_long): Remove function. (emit_rvalue_from_emacs_uint, emit_rvalue_from_lisp_word_tag) (emit_rvalue_from_lisp_word): Make use of 'emit_rvalue_from_long_long'. diff --git a/src/comp.c b/src/comp.c index ca6e990daa..24c40f7c3e 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1128,56 +1128,12 @@ emit_rvalue_from_long_long (gcc_jit_type *type, long long n) low)); } -#if (EMACS_INT_MAX > LONG_MAX) -static gcc_jit_rvalue * -emit_rvalue_from_unsigned_long_long (gcc_jit_type *type, unsigned long long n) -{ - emit_comment (format_string ("emit unsigned long long: %llu", n)); - - gcc_jit_rvalue *high = - gcc_jit_context_new_rvalue_from_long (comp.ctxt, - comp.unsigned_long_long_type, - n >> 32); - gcc_jit_rvalue *low = - emit_binary_op (GCC_JIT_BINARY_OP_RSHIFT, - comp.unsigned_long_long_type, - emit_binary_op (GCC_JIT_BINARY_OP_LSHIFT, - comp.unsigned_long_long_type, - gcc_jit_context_new_rvalue_from_long ( - comp.ctxt, - comp.unsigned_long_long_type, - n), - gcc_jit_context_new_rvalue_from_int ( - comp.ctxt, - comp.unsigned_long_long_type, - 32)), - gcc_jit_context_new_rvalue_from_int ( - comp.ctxt, - comp.unsigned_long_long_type, - 32)); - - return emit_coerce ( - type, - emit_binary_op ( - GCC_JIT_BINARY_OP_BITWISE_OR, - comp.unsigned_long_long_type, - emit_binary_op ( - GCC_JIT_BINARY_OP_LSHIFT, - comp.unsigned_long_long_type, - high, - gcc_jit_context_new_rvalue_from_int (comp.ctxt, - comp.unsigned_long_long_type, - 32)), - low)); -} -#endif - static gcc_jit_rvalue * emit_rvalue_from_emacs_uint (EMACS_UINT val) { #ifdef WIDE_EMACS_INT if (val > LONG_MAX || val < LONG_MIN) - return emit_rvalue_from_unsigned_long_long (comp.emacs_uint_type, val); + return emit_rvalue_from_long_long (comp.emacs_uint_type, val); #endif return gcc_jit_context_new_rvalue_from_long (comp.ctxt, comp.emacs_uint_type, @@ -1199,7 +1155,7 @@ emit_rvalue_from_lisp_word_tag (Lisp_Word_tag val) { #ifdef WIDE_EMACS_INT if (val > LONG_MAX || val < LONG_MIN) - return emit_rvalue_from_unsigned_long_long (comp.lisp_word_tag_type, val); + return emit_rvalue_from_long_long (comp.lisp_word_tag_type, val); #endif return gcc_jit_context_new_rvalue_from_long (comp.ctxt, comp.lisp_word_tag_type, @@ -1215,7 +1171,7 @@ emit_rvalue_from_lisp_word (Lisp_Word val) val); #else if (val > LONG_MAX || val < LONG_MIN) - return emit_rvalue_from_unsigned_long_long (comp.lisp_word_type, val); + return emit_rvalue_from_long_long (comp.lisp_word_type, val); else return gcc_jit_context_new_rvalue_from_long (comp.ctxt, comp.lisp_word_type, commit 14e6268d141b8c54001d1d5bdcf610313ac9c447 Author: Andrea Corallo Date: Fri Feb 19 15:54:36 2021 +0100 * Pacify GCC warning on non wide-int configurations * src/comp.c (emit_rvalue_from_emacs_uint) (emit_rvalue_from_lisp_word_tag): Pacify GCC warning. (emit_rvalue_from_unsigned_long_long): Define it only when necessary. diff --git a/src/comp.c b/src/comp.c index 3b1f3be268..ca6e990daa 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1128,6 +1128,7 @@ emit_rvalue_from_long_long (gcc_jit_type *type, long long n) low)); } +#if (EMACS_INT_MAX > LONG_MAX) static gcc_jit_rvalue * emit_rvalue_from_unsigned_long_long (gcc_jit_type *type, unsigned long long n) { @@ -1169,16 +1170,18 @@ emit_rvalue_from_unsigned_long_long (gcc_jit_type *type, unsigned long long n) 32)), low)); } +#endif static gcc_jit_rvalue * emit_rvalue_from_emacs_uint (EMACS_UINT val) { +#ifdef WIDE_EMACS_INT if (val > LONG_MAX || val < LONG_MIN) return emit_rvalue_from_unsigned_long_long (comp.emacs_uint_type, val); - else - return gcc_jit_context_new_rvalue_from_long (comp.ctxt, - comp.emacs_uint_type, - val); +#endif + return gcc_jit_context_new_rvalue_from_long (comp.ctxt, + comp.emacs_uint_type, + val); } static gcc_jit_rvalue * @@ -1194,12 +1197,13 @@ emit_rvalue_from_emacs_int (EMACS_INT val) static gcc_jit_rvalue * emit_rvalue_from_lisp_word_tag (Lisp_Word_tag val) { +#ifdef WIDE_EMACS_INT if (val > LONG_MAX || val < LONG_MIN) return emit_rvalue_from_unsigned_long_long (comp.lisp_word_tag_type, val); - else - return gcc_jit_context_new_rvalue_from_long (comp.ctxt, - comp.lisp_word_tag_type, - val); +#endif + return gcc_jit_context_new_rvalue_from_long (comp.ctxt, + comp.lisp_word_tag_type, + val); } static gcc_jit_rvalue * commit 2110a3faf776c68b2dbe52da3650636aec170269 Author: Andrea Corallo Date: Thu Feb 18 22:35:07 2021 +0100 * src/pdumper.c (dump_do_dump_relocation): Use emacs_fopen + ENCODE_FILE. diff --git a/src/pdumper.c b/src/pdumper.c index f053143a9f..368184b9a6 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -5280,10 +5280,10 @@ dump_do_dump_relocation (const uintptr_t dump_base, /* Check just once if this is a local build or Emacs was installed. */ if (installation_state == UNKNOWN) { - char *fname = SSDATA (concat2 (Vinvocation_directory, - XCAR (comp_u->file))); + Lisp_Object fname = + concat2 (Vinvocation_directory, XCAR (comp_u->file)); FILE *file; - if ((file = fopen (fname, "r"))) + if ((file = emacs_fopen (SSDATA (ENCODE_FILE (fname)), "r"))) { fclose (file); installation_state = INSTALLED; commit 805cae572aa62184c717db593e86e30ea9093059 Author: Andrea Corallo Date: Thu Feb 18 22:32:58 2021 +0100 * src/emacs.c (syms_of_emacs): Add a FIXME for Windows native-comp. diff --git a/src/emacs.c b/src/emacs.c index acf8a17a12..d541b41f3f 100644 --- a/src/emacs.c +++ b/src/emacs.c @@ -3081,9 +3081,9 @@ because they do not depend on external libraries and are always available. Also note that this is not a generic facility for accessing external libraries; only those already known by Emacs will be loaded. */); #ifdef WINDOWSNT - /* We may need to load libgccjit when dumping before term/w32-win.el - defines `dynamic-library-alist`. This will fail if that variable - is empty, so add libgccjit-0.dll to it. */ + /* FIXME: We may need to load libgccjit when dumping before + term/w32-win.el defines `dynamic-library-alist`. This will fail + if that variable is empty, so add libgccjit-0.dll to it. */ if (will_dump_p ()) Vdynamic_library_alist = list1 (list2 (Qgccjit, build_string ("libgccjit-0.dll"))); commit b1bab6e07396fb30a7a2ba8cb4fd42f44020f513 Author: Andrea Corallo Date: Thu Feb 18 22:10:20 2021 +0100 * Add a bunch of assertions for fixnums coming from Lisp later used as int * src/comp.c (emit_limple_insn, declare_lex_function) (compile_function, Fcomp__compile_ctxt_to_file): Add some assertion. diff --git a/src/comp.c b/src/comp.c index f3a3e5556f..3b1f3be268 100644 --- a/src/comp.c +++ b/src/comp.c @@ -2057,6 +2057,7 @@ emit_limple_insn (Lisp_Object insn) */ gcc_jit_lvalue *nargs = gcc_jit_param_as_lvalue (gcc_jit_function_get_param (comp.func, 0)); + eassert (XFIXNUM (arg[0]) < INT_MAX); gcc_jit_rvalue *n = gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.ptrdiff_type, @@ -2200,6 +2201,7 @@ emit_limple_insn (Lisp_Object insn) { /* Ex: (set-par-to-local #s(comp-mvar 0 3 nil nil nil nil) 0). */ EMACS_INT param_n = XFIXNUM (arg[1]); + eassert (param_n < INT_MAX); gcc_jit_rvalue *param = gcc_jit_param_as_rvalue (gcc_jit_function_get_param (comp.func, param_n)); @@ -2228,6 +2230,7 @@ emit_limple_insn (Lisp_Object insn) */ EMACS_INT slot_n = XFIXNUM (CALL1I (comp-mvar-slot, arg[0])); + eassert (slot_n < INT_MAX); gcc_jit_rvalue *n = gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.ptrdiff_type, @@ -3805,6 +3808,7 @@ declare_lex_function (Lisp_Object func) if (!nargs) { EMACS_INT max_args = XFIXNUM (CALL1I (comp-args-max, args)); + eassert (max_args < INT_MAX); gcc_jit_type **type = SAFE_ALLOCA (max_args * sizeof (*type)); for (ptrdiff_t i = 0; i < max_args; i++) type[i] = comp.lisp_obj_type; @@ -3869,6 +3873,7 @@ compile_function (Lisp_Object func) { USE_SAFE_ALLOCA; comp.frame_size = XFIXNUM (CALL1I (comp-func-frame-size, func)); + eassert (comp.frame_size < INT_MAX); comp.func = xmint_pointer (Fgethash (CALL1I (comp-func-c-name, func), comp.exported_funcs_h, Qnil)); @@ -4353,7 +4358,9 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, comp.func_relocs_local = NULL; comp.speed = XFIXNUM (CALL1I (comp-ctxt-speed, Vcomp_ctxt)); + eassert (comp.speed < INT_MAX); comp.debug = XFIXNUM (CALL1I (comp-ctxt-debug, Vcomp_ctxt)); + eassert (comp.debug < INT_MAX); if (comp.debug) gcc_jit_context_set_bool_option (comp.ctxt, commit 185121da6978553d538d37d6d0e67dc52e13311f Author: Andrea Corallo Date: Thu Feb 18 21:45:50 2021 +0100 * Add assertion guarding against emitting a relocation array overflow * src/comp.c (reloc_array_t): New type. (comp_t, imm_reloc_t): Make use of 'reloc_array_t'. (obj_to_reloc): Add an assertion not to overflow relocation arrays. (emit_lisp_obj_reloc_lval, emit_limple_insn) (declare_imported_data_relocs): Make use of 'reloc_array_t'. diff --git a/src/comp.c b/src/comp.c index 5e95161030..f3a3e5556f 100644 --- a/src/comp.c +++ b/src/comp.c @@ -488,6 +488,11 @@ enum cast_kind_of_type kind_pointer }; +typedef struct { + EMACS_INT len; + gcc_jit_rvalue *r_val; +} reloc_array_t; + /* C side of the compiler context. */ typedef struct { @@ -583,11 +588,11 @@ typedef struct { Lisp_Object imported_funcs_h; /* subr_name -> gcc_jit_field *reloc_field. */ Lisp_Object emitter_dispatcher; /* Synthesized struct holding data relocs. */ - gcc_jit_rvalue *data_relocs; + reloc_array_t data_relocs; /* Same as before but can't go in pure space. */ - gcc_jit_rvalue *data_relocs_impure; + reloc_array_t data_relocs_impure; /* Same as before but content does not survive load phase. */ - gcc_jit_rvalue *data_relocs_ephemeral; + reloc_array_t data_relocs_ephemeral; /* Global structure holding function relocations. */ gcc_jit_lvalue *func_relocs; gcc_jit_type *func_relocs_ptr_type; @@ -610,7 +615,7 @@ typedef struct { } static_obj_t; typedef struct { - gcc_jit_rvalue *array; + reloc_array_t array; gcc_jit_rvalue *idx; } imm_reloc_t; @@ -827,7 +832,9 @@ obj_to_reloc (Lisp_Object obj) xsignal1 (Qnative_ice, build_string ("cant't find data in relocation containers")); assume (false); + found: + eassert (XFIXNUM (idx) < reloc.array.len); if (!FIXNUMP (idx)) xsignal1 (Qnative_ice, build_string ("inconsistent data relocation container")); @@ -1558,7 +1565,7 @@ emit_lisp_obj_reloc_lval (Lisp_Object obj) imm_reloc_t reloc = obj_to_reloc (obj); return gcc_jit_context_new_array_access (comp.ctxt, NULL, - reloc.array, + reloc.array.r_val, reloc.idx); } @@ -2270,7 +2277,7 @@ emit_limple_insn (Lisp_Object insn) gcc_jit_lvalue_as_rvalue ( gcc_jit_context_new_array_access (comp.ctxt, NULL, - reloc.array, + reloc.array.r_val, reloc.idx))); } else if (EQ (op, Qcomment)) @@ -2608,18 +2615,19 @@ emit_static_object (const char *name, Lisp_Object obj) } #pragma GCC diagnostic pop -static gcc_jit_rvalue * +static reloc_array_t declare_imported_data_relocs (Lisp_Object container, const char *code_symbol, const char *text_symbol) { /* Imported objects. */ - EMACS_INT d_reloc_len = + reloc_array_t res; + res.len = XFIXNUM (CALL1I (hash-table-count, CALL1I (comp-data-container-idx, container))); Lisp_Object d_reloc = CALL1I (comp-data-container-l, container); d_reloc = Fvconcat (1, &d_reloc); - gcc_jit_rvalue *reloc_struct = + res.r_val = gcc_jit_lvalue_as_rvalue ( gcc_jit_context_new_global ( comp.ctxt, @@ -2628,12 +2636,12 @@ declare_imported_data_relocs (Lisp_Object container, const char *code_symbol, gcc_jit_context_new_array_type (comp.ctxt, NULL, comp.lisp_obj_type, - d_reloc_len), + res.len), code_symbol)); emit_static_object (text_symbol, d_reloc); - return reloc_struct; + return res; } static void commit f92bb788a073c6b3ca7f188e0edea714598193fd Merge: 1fe5994bcb 6735bb3d22 Author: Andrea Corallo Date: Wed Feb 17 22:26:28 2021 +0100 Merge remote-tracking branch 'savannah/master' into native-comp commit 1fe5994bcb8b58012dbba0a5f7d03138c293286f Author: Andrea Corallo Date: Wed Feb 17 21:45:37 2021 +0100 Fix inverted logic in constraint comparison (bug#46540) * lisp/emacs-lisp/comp-cstr.el (comp-cstr->, comp-cstr->=) (comp-cstr-<, comp-cstr-<=): Fix inverted logic. * test/src/comp-tests.el (comp-tests-type-spec-tests): Add three integer constrain tests. diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el index 1afb928e10..3c00b68d0f 100644 --- a/lisp/emacs-lisp/comp-cstr.el +++ b/lisp/emacs-lisp/comp-cstr.el @@ -791,7 +791,7 @@ SRC can be either a comp-cstr or an integer." (if (integerp src) `((,(1+ src) . +)) (when-let* ((range (range src)) - (low (comp-cstr-greatest-in-range range)) + (low (comp-cstr-smallest-in-range range)) (okay (integerp low))) `((,(1+ low) . +)))))) (comp-cstr-set-cmp-range dst old-dst ext-range)))) @@ -804,7 +804,7 @@ SRC can be either a comp-cstr or an integer." (if (integerp src) `((,src . +)) (when-let* ((range (range src)) - (low (comp-cstr-greatest-in-range range)) + (low (comp-cstr-smallest-in-range range)) (okay (integerp low))) `((,low . +)))))) (comp-cstr-set-cmp-range dst old-dst ext-range)))) @@ -817,7 +817,7 @@ SRC can be either a comp-cstr or an integer." (if (integerp src) `((- . ,(1- src))) (when-let* ((range (range src)) - (low (comp-cstr-smallest-in-range range)) + (low (comp-cstr-greatest-in-range range)) (okay (integerp low))) `((- . ,(1- low))))))) (comp-cstr-set-cmp-range dst old-dst ext-range)))) @@ -830,7 +830,7 @@ SRC can be either a comp-cstr or an integer." (if (integerp src) `((- . ,src)) (when-let* ((range (range src)) - (low (comp-cstr-smallest-in-range range)) + (low (comp-cstr-greatest-in-range range)) (okay (integerp low))) `((- . ,low)))))) (comp-cstr-set-cmp-range dst old-dst ext-range)))) diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index c0325a8d5d..08c1889441 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -1211,7 +1211,34 @@ Return a list of results." (= x 3)) (error "Not foo or 3")) x) - (or (member foo) (integer 3 3))))) + (or (member foo) (integer 3 3))) + + ;;58 + ((defun comp-tests-ret-type-spec-f (x y) + (if (and (natnump x) + (natnump y) + (<= x y)) + x + (error ""))) + (integer 0 *)) + + ;; 59 + ((defun comp-tests-ret-type-spec-f (x y) + (if (and (>= x 3) + (<= y 10) + (<= x y)) + x + (error ""))) + (or float (integer 3 10))) + + ;; 60 + ((defun comp-tests-ret-type-spec-f (x y) + (if (and (<= x 10) + (>= y 3) + (>= x y)) + x + (error ""))) + (or float (integer 3 10))))) (defun comp-tests-define-type-spec-test (number x) `(comp-deftest ,(intern (format "ret-type-spec-%d" number)) () commit 0d7c893203087d60f0ce549521f4c715c87a7038 Author: Andrea Corallo Date: Wed Feb 17 15:53:24 2021 +0100 * src/comp.c (Fcomp__compile_ctxt_to_file): Clean-up unused variable. diff --git a/src/comp.c b/src/comp.c index c9d14958b7..5e95161030 100644 --- a/src/comp.c +++ b/src/comp.c @@ -4376,8 +4376,6 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, comp.d_ephemeral_idx = CALL1I (comp-data-container-idx, CALL1I (comp-ctxt-d-ephemeral, Vcomp_ctxt)); - ptrdiff_t count = 0; - emit_ctxt_code (); /* Define inline functions. */ commit 21858596f0271a2215174d99c9007f6b2f1f5e21 Author: Andrea Corallo Date: Tue Feb 16 22:05:06 2021 +0100 * Clean-up some signal related dead-code * src/comp.c (restore_sigmask): Remove function. (Fcomp__compile_ctxt_to_file): Remove some dead-code. diff --git a/src/comp.c b/src/comp.c index dae68ddb2b..c9d14958b7 100644 --- a/src/comp.c +++ b/src/comp.c @@ -4331,13 +4331,6 @@ add_driver_options (void) " and above.")); } -static void -restore_sigmask (void) -{ - pthread_sigmask (SIG_SETMASK, &saved_sigset, 0); - unblock_input (); -} - DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, Scomp__compile_ctxt_to_file, 1, 1, 0, @@ -4385,21 +4378,6 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, ptrdiff_t count = 0; - if (!noninteractive) - { - sigset_t blocked; - /* Gcc doesn't like being interrupted at all. */ - block_input (); - sigemptyset (&blocked); - sigaddset (&blocked, SIGALRM); - sigaddset (&blocked, SIGINT); -#ifdef USABLE_SIGIO - sigaddset (&blocked, SIGIO); -#endif - pthread_sigmask (SIG_BLOCK, &blocked, &saved_sigset); - count = SPECPDL_INDEX (); - record_unwind_protect_void (restore_sigmask); - } emit_ctxt_code (); /* Define inline functions. */ @@ -4451,9 +4429,6 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, CALL1I (comp-clean-up-stale-eln, filename); CALL2I (comp-delete-or-replace-file, filename, tmp_file); - if (!noninteractive) - unbind_to (count, Qnil); - return filename; } commit 7b676861dd1080ac65368d8b975972acb5bb1da8 Author: Andrea Corallo Date: Tue Feb 16 22:01:27 2021 +0100 * src/comp.c (check_comp_unit_relocs): Prefer ptrdiff_t to EMACS_INT. diff --git a/src/comp.c b/src/comp.c index ce9c387568..dae68ddb2b 100644 --- a/src/comp.c +++ b/src/comp.c @@ -4713,12 +4713,12 @@ check_comp_unit_relocs (struct Lisp_Native_Comp_Unit *comp_u) Lisp_Object *data_imp_relocs = dynlib_sym (handle, DATA_RELOC_IMPURE_SYM); EMACS_INT d_vec_len = XFIXNUM (Flength (comp_u->data_vec)); - for (EMACS_INT i = 0; i < d_vec_len; i++) + for (ptrdiff_t i = 0; i < d_vec_len; i++) if (!EQ (data_relocs[i], AREF (comp_u->data_vec, i))) return false; d_vec_len = XFIXNUM (Flength (comp_u->data_impure_vec)); - for (EMACS_INT i = 0; i < d_vec_len; i++) + for (ptrdiff_t i = 0; i < d_vec_len; i++) { Lisp_Object x = data_imp_relocs[i]; if (EQ (x, Qlambda_fixup)) commit 72e4a22391bcb5d4ef484eb1dd32a614dbdbfd7b Author: Andrea Corallo Date: Tue Feb 16 21:49:32 2021 +0100 * Better long range check * src/comp.c (emit_rvalue_from_emacs_uint) (emit_rvalue_from_emacs_int, emit_rvalue_from_lisp_word_tag) (emit_rvalue_from_lisp_word): Better long range check. diff --git a/src/comp.c b/src/comp.c index 0ab7ab600a..ce9c387568 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1166,7 +1166,7 @@ emit_rvalue_from_unsigned_long_long (gcc_jit_type *type, unsigned long long n) static gcc_jit_rvalue * emit_rvalue_from_emacs_uint (EMACS_UINT val) { - if (val != (long) val) + if (val > LONG_MAX || val < LONG_MIN) return emit_rvalue_from_unsigned_long_long (comp.emacs_uint_type, val); else return gcc_jit_context_new_rvalue_from_long (comp.ctxt, @@ -1177,7 +1177,7 @@ emit_rvalue_from_emacs_uint (EMACS_UINT val) static gcc_jit_rvalue * emit_rvalue_from_emacs_int (EMACS_INT val) { - if (val != (long) val) + if (val > LONG_MAX || val < LONG_MIN) return emit_rvalue_from_long_long (comp.emacs_int_type, val); else return gcc_jit_context_new_rvalue_from_long (comp.ctxt, @@ -1187,7 +1187,7 @@ emit_rvalue_from_emacs_int (EMACS_INT val) static gcc_jit_rvalue * emit_rvalue_from_lisp_word_tag (Lisp_Word_tag val) { - if (val != (long) val) + if (val > LONG_MAX || val < LONG_MIN) return emit_rvalue_from_unsigned_long_long (comp.lisp_word_tag_type, val); else return gcc_jit_context_new_rvalue_from_long (comp.ctxt, @@ -1203,7 +1203,7 @@ emit_rvalue_from_lisp_word (Lisp_Word val) comp.lisp_word_type, val); #else - if (val != (long) val) + if (val > LONG_MAX || val < LONG_MIN) return emit_rvalue_from_unsigned_long_long (comp.lisp_word_type, val); else return gcc_jit_context_new_rvalue_from_long (comp.ctxt, commit 543e6e664cf1f25fd7df04e75ffb582f5c7feab4 Author: Andrea Corallo Date: Tue Feb 16 21:41:36 2021 +0100 * Sanitize frame slot access in final * src/comp.c (comp_t): Add 'frame_size' field. (emit_mvar_lval): Add sanity check on frame element access. (compile_function): Initialize 'comp.frame_size' and 'comp.frame_size'. diff --git a/src/comp.c b/src/comp.c index df770c650e..0ab7ab600a 100644 --- a/src/comp.c +++ b/src/comp.c @@ -560,6 +560,7 @@ typedef struct { EMACS_INT func_speed; /* From comp-func speed slot. */ gcc_jit_block *block; /* Current basic block being compiled. */ gcc_jit_lvalue *scratch; /* Used as scratch slot for some code sequence (switch). */ + ptrdiff_t frame_size; /* Size of the following array in elements. */ gcc_jit_lvalue **frame; /* Frame slot n -> gcc_jit_lvalue *. */ gcc_jit_rvalue *zero; gcc_jit_rvalue *one; @@ -785,7 +786,9 @@ emit_mvar_lval (Lisp_Object mvar) return comp.scratch; } - return comp.frame[XFIXNUM (mvar_slot)]; + EMACS_INT slot_n = XFIXNUM (mvar_slot); + eassert (slot_n < comp.frame_size); + return comp.frame[slot_n]; } static void @@ -3857,7 +3860,7 @@ static void compile_function (Lisp_Object func) { USE_SAFE_ALLOCA; - EMACS_INT frame_size = XFIXNUM (CALL1I (comp-func-frame-size, func)); + comp.frame_size = XFIXNUM (CALL1I (comp-func-frame-size, func)); comp.func = xmint_pointer (Fgethash (CALL1I (comp-func-c-name, func), comp.exported_funcs_h, Qnil)); @@ -3871,7 +3874,7 @@ compile_function (Lisp_Object func) comp.func_relocs_ptr_type, "freloc"); - comp.frame = SAFE_ALLOCA (frame_size * sizeof (*comp.frame)); + comp.frame = SAFE_ALLOCA (comp.frame_size * sizeof (*comp.frame)); if (comp.func_has_non_local || !comp.func_speed) { /* FIXME: See bug#42360. */ @@ -3882,10 +3885,10 @@ compile_function (Lisp_Object func) gcc_jit_context_new_array_type (comp.ctxt, NULL, comp.lisp_obj_type, - frame_size), + comp.frame_size), "frame"); - for (ptrdiff_t i = 0; i < frame_size; ++i) + for (ptrdiff_t i = 0; i < comp.frame_size; ++i) comp.frame[i] = gcc_jit_context_new_array_access ( comp.ctxt, @@ -3896,7 +3899,7 @@ compile_function (Lisp_Object func) i)); } else - for (ptrdiff_t i = 0; i < frame_size; ++i) + for (ptrdiff_t i = 0; i < comp.frame_size; ++i) comp.frame[i] = gcc_jit_function_new_local (comp.func, NULL, commit 31416495ad9b2c84473f72ad99e2adc87dd66e5a Author: Andrea Corallo Date: Sun Feb 14 21:14:34 2021 +0100 * lisp/startup.el (normal-top-level): Use `path-separator' in place of ":". diff --git a/lisp/startup.el b/lisp/startup.el index ae0ac3cb93..7e8fa47aea 100644 --- a/lisp/startup.el +++ b/lisp/startup.el @@ -540,7 +540,7 @@ It is the default value of the variable `top-level'." (defvar comp-eln-load-path) (let ((path-env (getenv "EMACSNATIVELOADPATH"))) (when path-env - (dolist (path (split-string path-env ":")) + (dolist (path (split-string path-env path-separator)) (unless (string= "" path) (push path comp-eln-load-path))))) (push (concat user-emacs-directory "eln-cache/") comp-eln-load-path)) commit 71fc39cbe009fefcb992d8333806a743a3b97243 Author: Andrea Corallo Date: Sun Feb 14 20:19:28 2021 +0100 Revert "* src/comp.c (define_jmp_buf): Use 'jmp_buf' instead of 'sys_jmp_buf'." This reverts commit bebec46bcbf0e52460b08234c067d7a2cb0f2246. Looking at the git history I realize now the use of 'sys_jmp_buf' was intentional. diff --git a/src/comp.c b/src/comp.c index 737e808020..df770c650e 100644 --- a/src/comp.c +++ b/src/comp.c @@ -2937,7 +2937,7 @@ define_jmp_buf (void) gcc_jit_context_new_array_type (comp.ctxt, NULL, comp.char_type, - sizeof (jmp_buf)), + sizeof (sys_jmp_buf)), "stuff"); comp.jmp_buf_s = gcc_jit_context_new_struct_type (comp.ctxt, commit bebec46bcbf0e52460b08234c067d7a2cb0f2246 Author: Andrea Corallo Date: Sun Feb 14 20:08:09 2021 +0100 * src/comp.c (define_jmp_buf): Use 'jmp_buf' instead of 'sys_jmp_buf'. diff --git a/src/comp.c b/src/comp.c index df770c650e..737e808020 100644 --- a/src/comp.c +++ b/src/comp.c @@ -2937,7 +2937,7 @@ define_jmp_buf (void) gcc_jit_context_new_array_type (comp.ctxt, NULL, comp.char_type, - sizeof (sys_jmp_buf)), + sizeof (jmp_buf)), "stuff"); comp.jmp_buf_s = gcc_jit_context_new_struct_type (comp.ctxt, commit 8646113ba0c523827f07b01585c3fd1080d3d7b8 Author: Andrea Corallo Date: Sun Feb 14 19:56:19 2021 +0100 * src/comp.c (load_comp_unit): Fix 'data_ephemeral_vec' shadowing decl. diff --git a/src/comp.c b/src/comp.c index 289d89d37d..df770c650e 100644 --- a/src/comp.c +++ b/src/comp.c @@ -4858,7 +4858,7 @@ load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u, bool loading_dump, is not cons hashed. */ if (!recursive_load) { - Lisp_Object volatile data_ephemeral_vec = + data_ephemeral_vec = load_static_obj (comp_u, TEXT_DATA_RELOC_EPHEMERAL_SYM); EMACS_INT d_vec_len = XFIXNUM (Flength (data_ephemeral_vec)); commit d3a399dd299bf7e811cf42950d5f8ac67f063b36 Author: Andrea Corallo Date: Thu Feb 11 21:37:53 2021 +0100 * lisp/emacs-lisp/comp.el (comp-trampoline-compile): Default to speed 1. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 02a9f4ae1f..4036080976 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -3661,7 +3661,7 @@ Return the trampoline if found or nil otherwise." ;; Use speed 0 to maximize compilation speed and not to ;; optimize away funcall calls! (byte-optimize nil) - (comp-speed 0) + (comp-speed 1) (lexical-binding t)) (comp--native-compile form nil commit 4fba79feee58e074d112bb47467913f9aec089c7 Author: Andrea Corallo Date: Wed Feb 10 21:48:19 2021 +0100 Add late load pdumper hooks so these can call into Lisp * src/pdumper.h (pdumper_do_now_and_after_late_load): New function. * src/pdumper.c (dump_late_hooks, nr_dump_late_hooks): New static variables. (dump_metadata_for_pdumper): Add support for late load hooks. (pdumper_do_now_and_after_late_load_impl): New functions. (pdumper_load): Add support for late load hooks. * src/window.c (init_window_once): Register 'init_window_once_for_pdumper' to be executed after late load. diff --git a/src/pdumper.c b/src/pdumper.c index f0711078a5..1f1f6e05df 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -121,6 +121,9 @@ static const char dump_magic[16] = { static pdumper_hook dump_hooks[24]; static int nr_dump_hooks = 0; +static pdumper_hook dump_late_hooks[24]; +static int nr_dump_late_hooks = 0; + static struct { void *mem; @@ -3245,6 +3248,12 @@ dump_metadata_for_pdumper (struct dump_context *ctx) (void const *) dump_hooks[i]); dump_emacs_reloc_immediate_int (ctx, &nr_dump_hooks, nr_dump_hooks); + for (int i = 0; i < nr_dump_late_hooks; ++i) + dump_emacs_reloc_to_emacs_ptr_raw (ctx, &dump_late_hooks[i], + (void const *) dump_late_hooks[i]); + dump_emacs_reloc_immediate_int (ctx, &nr_dump_late_hooks, + nr_dump_late_hooks); + for (int i = 0; i < nr_remembered_data; ++i) { dump_emacs_reloc_to_emacs_ptr_raw (ctx, &remembered_data[i].mem, @@ -4316,6 +4325,15 @@ pdumper_do_now_and_after_load_impl (pdumper_hook hook) hook (); } +void +pdumper_do_now_and_after_late_load_impl (pdumper_hook hook) +{ + if (nr_dump_late_hooks == ARRAYELTS (dump_late_hooks)) + fatal ("out of dump hooks: make dump_late_hooks[] bigger"); + dump_late_hooks[nr_dump_late_hooks++] = hook; + hook (); +} + static void pdumper_remember_user_data_1 (void *mem, int nbytes) { @@ -5597,6 +5615,12 @@ pdumper_load (const char *dump_filename, char *argv0, char const *original_pwd) dump_do_all_dump_reloc_for_phase (header, dump_base, LATE_RELOCS); dump_do_all_dump_reloc_for_phase (header, dump_base, VERY_LATE_RELOCS); + + /* Run the functions Emacs registered for doing post-dump-load + initialization. */ + for (int i = 0; i < nr_dump_late_hooks; ++i) + dump_late_hooks[i] (); + initialized = true; struct timespec load_timespec = diff --git a/src/pdumper.h b/src/pdumper.h index 24e99e22c7..49e6739b0d 100644 --- a/src/pdumper.h +++ b/src/pdumper.h @@ -81,6 +81,7 @@ pdumper_remember_lv_ptr_raw (void *ptr, enum Lisp_Type type) typedef void (*pdumper_hook)(void); extern void pdumper_do_now_and_after_load_impl (pdumper_hook hook); +extern void pdumper_do_now_and_after_late_load_impl (pdumper_hook hook); INLINE void pdumper_do_now_and_after_load (pdumper_hook hook) @@ -92,6 +93,18 @@ pdumper_do_now_and_after_load (pdumper_hook hook) #endif } +/* Same as 'pdumper_do_now_and_after_load' but for hooks running code + that can call into Lisp. */ +INLINE void +pdumper_do_now_and_after_late_load (pdumper_hook hook) +{ +#ifdef HAVE_PDUMPER + pdumper_do_now_and_after_late_load_impl (hook); +#else + hook (); +#endif +} + /* Macros useful in pdumper callback functions. Assign a value if we're loading a dump and the value needs to be reset to its original value, and if we're initializing for the first time, diff --git a/src/window.c b/src/window.c index eb16e2a433..f8b97287e6 100644 --- a/src/window.c +++ b/src/window.c @@ -8134,7 +8134,7 @@ init_window_once (void) minibuf_selected_window = Qnil; staticpro (&minibuf_selected_window); - pdumper_do_now_and_after_load (init_window_once_for_pdumper); + pdumper_do_now_and_after_late_load (init_window_once_for_pdumper); } static void init_window_once_for_pdumper (void) commit 2fcb85c3e780f1f2871ce0f300cfaffce9836eb0 Merge: 1f626e9662 6bfdfeed36 Author: Andrea Corallo Date: Wed Feb 10 21:56:55 2021 +0100 Merge remote-tracking branch 'savannah/master' into HEAD commit 1f626e9662d8120acd5a937f847123cc2b8c6e31 Author: Andrea Corallo Date: Wed Feb 3 21:10:47 2021 +0100 * Remove `system-configuration' from eln filename * src/comp.c (hash_native_abi): Remove `system-configuration' from eln filename. Add `system-configuration' and `emacs-version' into `comp-abi-hash'. diff --git a/src/comp.c b/src/comp.c index 1b346f847d..289d89d37d 100644 --- a/src/comp.c +++ b/src/comp.c @@ -704,16 +704,12 @@ hash_native_abi (void) Vcomp_abi_hash = comp_hash_string ( - concat2 (build_string (ABI_VERSION), + concat3 (build_string (ABI_VERSION), + concat2 (Vemacs_version, Vsystem_configuration), Fmapconcat (intern_c_string ("subr-name"), Vcomp_subr_list, build_string ("")))); - Lisp_Object separator = build_string ("-"); Vcomp_native_version_dir = - concat3 (Vemacs_version, - separator, - concat3 (Vsystem_configuration, - separator, - Vcomp_abi_hash)); + concat3 (Vemacs_version, build_string ("-"), Vcomp_abi_hash); } static void commit 41509d873e8a05aa98133cb78f384e06e69779ab Author: Andrea Corallo Date: Tue Feb 2 21:20:28 2021 +0100 * Short eln filename hashes * src/comp.c (HASH_LENGTH): New macro. (comp_hash_string, comp_hash_source_file): Trim the hash before returning. diff --git a/src/comp.c b/src/comp.c index b5adc3ed86..1b346f847d 100644 --- a/src/comp.c +++ b/src/comp.c @@ -413,6 +413,9 @@ load_gccjit_if_necessary (bool mandatory) /* Increase this number to force a new Vcomp_abi_hash to be generated. */ #define ABI_VERSION "1" +/* Length of the hashes used for eln file naming. */ +#define HASH_LENGTH 8 + /* C symbols emitted for the load relocation mechanism. */ #define CURRENT_THREAD_RELOC_SYM "current_thread_reloc" #define PURE_RELOC_SYM "pure_reloc" @@ -662,7 +665,7 @@ comp_hash_string (Lisp_Object string) md5_buffer (SSDATA (string), SCHARS (string), SSDATA (digest)); hexbuf_digest (SSDATA (digest), SDATA (digest), MD5_DIGEST_SIZE); - return digest; + return Fsubstring (digest, Qnil, make_fixnum (HASH_LENGTH)); } static Lisp_Object @@ -688,7 +691,7 @@ comp_hash_source_file (Lisp_Object filename) hexbuf_digest (SSDATA (digest), SSDATA (digest), MD5_DIGEST_SIZE); - return digest; + return Fsubstring (digest, Qnil, make_fixnum (HASH_LENGTH)); } /* Produce a key hashing Vcomp_subr_list. */ commit a8b8d220b4fccaa812e85f9b2b3715593dc285ac Merge: b8d3ae78c5 ed2f2cc557 Author: Andrea Corallo Date: Sat Jan 30 14:09:37 2021 +0100 Merge remote-tracking branch 'savannah/master' into native-comp commit b8d3ae78c54db7c7bb65d367a80f9be3d8744c48 Merge: 0ffb3dfaa4 e5aaa1251c Author: Andrea Corallo Date: Sun Jan 24 21:05:33 2021 +0100 Merge remote-tracking branch 'savannah/master' into native-comp commit 0ffb3dfaa483b0c5cf1f7f367efcb5e9c041ab53 Author: Andrea Corallo Date: Mon Jan 18 22:37:52 2021 +0100 Do not add unnecesary arg constraints (bug#45812 bug#45705 bug#45751). These have the effect of bloating the IR for no effect killing compile time. The typical cases for that are extremely long backuoted lists. * lisp/emacs-lisp/comp-cstr.el (comp-cstr-t): New var. * lisp/emacs-lisp/comp.el (comp-add-call-cstr): No need to add arg call constraints if this is t. diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el index 651c7b7931..1afb928e10 100644 --- a/lisp/emacs-lisp/comp-cstr.el +++ b/lisp/emacs-lisp/comp-cstr.el @@ -179,6 +179,9 @@ Return them as multiple value." (defvar comp-cstr-one (comp-value-to-cstr 1) "Represent the integer immediate one.") +(defvar comp-cstr-t (comp-type-to-cstr t) + "Represent the superclass t.") + ;;; Value handling. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index d2e0d0fb79..02a9f4ae1f 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2513,6 +2513,9 @@ TARGET-BB-SYM is the symbol name of the target block." do (signal 'native-ice (list "Incoherent type specifier for function" f)) when (and target + ;; No need to add call constraints if this is t + ;; (bug#45812 bug#45705 bug#45751). + (not (equal comp-cstr-t cstr)) (or (null lhs) (not (eql (comp-mvar-slot lhs) (comp-mvar-slot target))))) commit 39b3bcd324c4519ae3b204a31ab1a385b8ba9574 Author: Andrea Corallo Date: Sun Jan 17 22:00:42 2021 +0100 * Run dead code removal always before fwprop, optim bootstrap time (~20% less) * lisp/emacs-lisp/comp.el (comp-passes): Remove `comp-dead-code'. (comp-fwprop): Call `comp-dead-code'. (comp-dead-code): Remove fake arg. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index d4faa207b5..d2e0d0fb79 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -175,7 +175,6 @@ Can be one of: 'd-default', 'd-impure' or 'd-ephemeral'. See `comp-ctxt'.") comp-ipa-pure comp-add-cstrs comp-fwprop - comp-dead-code comp-tco comp-fwprop comp-remove-type-hints @@ -3130,6 +3129,7 @@ Return t if something was changed." (defun comp-fwprop (_) "Forward propagate types and consts within the lattice." (comp-ssa) + (comp-dead-code) (maphash (lambda (_ f) (when (and (>= (comp-func-speed f) 2) ;; FIXME remove the following condition when tested. @@ -3302,7 +3302,7 @@ Return the list of m-var ids nuked." insn)))))))) nuke-list))) -(defun comp-dead-code (_) +(defun comp-dead-code () "Dead code elimination." (maphash (lambda (_ f) (when (and (>= (comp-func-speed f) 2) commit 339b4a754b0abe8e376c96ff3ca9624d8942cab2 Author: Andrea Corallo Date: Thu Jan 14 23:54:52 2021 +0100 * Introduce `comp-fwprop-max-insns-scan' as heuristic threshold * lisp/emacs-lisp/comp.el (comp-fwprop-max-insns-scan): New constant. (comp-fwprop*): Give-up when `comp-fwprop-max-insns-scan' is exceeded. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 238d86f7d5..d4faa207b5 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2926,6 +2926,11 @@ Return t when one or more block was removed, nil otherwise." ;; This is also responsible for removing function calls to pure functions if ;; possible. +(defconst comp-fwprop-max-insns-scan 4500 + ;; Choosen as ~ the greatest required value for full convergence + ;; native compiling all Emacs codebase. + "Max number of scanned insn before giving-up.") + (defun comp-copy-insn (insn) "Deep copy INSN." ;; Adapted from `copy-tree'. @@ -3086,7 +3091,9 @@ Fold the call in case." (defun comp-fwprop* () "Propagate for set* and phi operands. Return t if something was changed." - (cl-loop with modified = nil + (cl-loop named outer + with modified = nil + with i = 0 for b being each hash-value of (comp-func-blocks comp-func) do (cl-loop with comp-block = b @@ -3094,9 +3101,13 @@ Return t if something was changed." for orig-insn = (unless modified ;; Save consing after 1th change. (comp-copy-insn insn)) - do (comp-fwprop-insn insn) + do + (comp-fwprop-insn insn) + (cl-incf i) when (and (null modified) (not (equal insn orig-insn))) do (setf modified t)) + when (> i comp-fwprop-max-insns-scan) + do (cl-return-from outer nil) finally return modified)) (defun comp-rewrite-non-locals () commit 883d937320a8be2bdc6d0ab7b5dd9551cbfeebd4 Author: Andrea Corallo Date: Sun Jan 17 16:50:16 2021 +0100 Make `comp-enable-subr-trampolines' effective for advices (bug#45854) * src/comp.c: Copyright update. (syms_of_comp): Update `comp-enable-subr-trampolines' doc. * lisp/emacs-lisp/comp.el (comp-subr-trampoline-install): Check for `comp-enable-subr-trampolines'. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index d127cea449..238d86f7d5 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -3668,7 +3668,8 @@ Return the trampoline if found or nil otherwise." ;;;###autoload (defun comp-subr-trampoline-install (subr-name) "Make SUBR-NAME effectively advice-able when called from native code." - (unless (or (memq subr-name comp-never-optimize-functions) + (unless (or (null comp-enable-subr-trampolines) + (memq subr-name comp-never-optimize-functions) (gethash subr-name comp-installed-trampolines-h)) (cl-assert (subr-primitive-p (symbol-function subr-name))) (comp--install-trampoline diff --git a/src/comp.c b/src/comp.c index 619f5e1b65..b5adc3ed86 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1,5 +1,5 @@ /* Compile elisp into native code. - Copyright (C) 2019-2020 Free Software Foundation, Inc. + Copyright (C) 2019-2021 Free Software Foundation, Inc. Author: Andrea Corallo @@ -5269,8 +5269,8 @@ The last directory of this list is assumed to be the system one. */); Vcomp_eln_load_path = Fcons (build_string ("../native-lisp/"), Qnil); DEFVAR_BOOL ("comp-enable-subr-trampolines", comp_enable_subr_trampolines, - doc: /* If non-nil, enable trampoline synthesis triggered by `fset'. -This makes primitives redefinable effectively. */); + doc: /* If non-nil enable primitive trampoline synthesis. +This makes primitive functions redefinable or advisable effectively. */); DEFVAR_LISP ("comp-installed-trampolines-h", Vcomp_installed_trampolines_h, doc: /* Hash table subr-name -> installed trampoline. commit 88100bed0af530f04cf56acca9f9d1bb12b45771 Author: Philip Brown Date: Fri Jan 15 00:35:36 2021 -0800 * Set `backtrace-line-length' in async worker processes Philip Brown * lisp/emacs-lisp/comp.el (comp-run-async-workers): Set backtrace-line-length in async worker processes. Copyright-paperwork-exempt: yes diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 875f15aa75..d127cea449 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -3802,6 +3802,8 @@ display a message." source-file (comp-el-to-eln-filename source-file))) do (let* ((expr `(progn (require 'comp) + ,(when (boundp 'backtrace-line-length) + `(setf backtrace-line-length ,backtrace-line-length)) (setf comp-speed ,comp-speed comp-debug ,comp-debug comp-verbose ,comp-verbose commit 0a7ac0b5504e75275699a3d8d2d5d94bcfda8708 Merge: f1efac1f9e 0732fc3193 Author: Andrea Corallo Date: Sat Jan 16 13:26:10 2021 +0100 Merge remote-tracking branch 'savannah/master' into native-comp commit f1efac1f9efbfa15b6434ebef507c00c1277633f Author: Andrea Corallo Date: Thu Jan 14 21:53:41 2021 +0100 * Normalize `comp-eln-load-path' entries for trampoline comp (bug#43475) * lisp/emacs-lisp/comp.el (comp-eln-load-path-eff): New function. (comp-trampoline-search, comp-trampoline-compile) (comp-clean-up-stale-eln): Update to use normalized `comp-eln-load-path-eff'. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 156b00e627..875f15aa75 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -3592,6 +3592,15 @@ Prepare every function for final compilation and drive the C back-end." ;; Primitive function advice machinery +(defun comp-eln-load-path-eff () + "Return a list of effective eln load directories. +Account for `comp-load-path' and `comp-native-version-dir'." + (mapcar (lambda (dir) + (concat (file-name-as-directory + (expand-file-name dir invocation-directory)) + comp-native-version-dir)) + comp-eln-load-path)) + (defun comp-trampoline-filename (subr-name) "Given SUBR-NAME return the filename containing the trampoline." (concat (comp-c-func-name subr-name "subr--trampoline-" t) ".eln")) @@ -3616,9 +3625,8 @@ Prepare every function for final compilation and drive the C back-end." Return the trampoline if found or nil otherwise." (cl-loop with rel-filename = (comp-trampoline-filename subr-name) - for dir in comp-eln-load-path - for filename = (expand-file-name rel-filename - (concat dir comp-native-version-dir)) + for dir in (comp-eln-load-path-eff) + for filename = (expand-file-name rel-filename dir) when (file-exists-p filename) do (cl-return (native-elisp-load filename)))) @@ -3644,8 +3652,7 @@ Return the trampoline if found or nil otherwise." (comp--native-compile form nil (cl-loop - for load-dir in comp-eln-load-path - for dir = (concat load-dir comp-native-version-dir) + for dir in (comp-eln-load-path-eff) for f = (expand-file-name (comp-trampoline-filename subr-name) dir) @@ -3684,11 +3691,10 @@ sharing the original source filename (including FILE)." with filename-hash = (match-string 1 file) with regexp = (rx-to-string `(seq "-" ,filename-hash "-" (1+ hex) ".eln" eos)) - for dir in (butlast comp-eln-load-path) ; Skip last dir. + for dir in (butlast (comp-eln-load-path-eff)) ; Skip last dir. do (cl-loop - with full-dir = (concat dir comp-native-version-dir) - for f in (when (file-exists-p full-dir) - (directory-files full-dir t regexp t)) + for f in (when (file-exists-p dir) + (directory-files dir t regexp t)) do (comp-delete-or-replace-file f))))) (defun comp-delete-or-replace-file (oldfile &optional newfile) @@ -3877,14 +3883,14 @@ load once finished compiling." for t0 = (current-time) for pass in comp-passes unless (memq pass comp-disabled-passes) - do - (comp-log (format "(%s) Running pass %s:\n" + 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)) + (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) commit 00101a8d4cc5bbf875711753c936be52e6e549b1 Author: Andrea Corallo Date: Sun Jan 10 15:39:16 2021 +0100 * Introduce native compilation time reports * lisp/emacs-lisp/comp.el (comp-log-time-report): New special variable. (comp--native-compile): Rework to log time reports. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index d5ca3b0004..156b00e627 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -142,6 +142,9 @@ The reproducer is a file ELNFILENAME_libgccjit_repro.c deposed in the .eln output directory." :type 'boolean) +(defvar comp-log-time-report nil + "If non-nil, log a time report for each pass.") + (defvar comp-dry-run nil "If non-nil, run everything but the C back-end.") @@ -3869,15 +3872,24 @@ load once finished compiling." :with-late-load with-late-load))) (comp-log "\n \n" 1) (condition-case err - (mapc (lambda (pass) - (unless (memq pass comp-disabled-passes) - (comp-log (format "(%s) Running pass %s:\n" - function-or-file pass) - 2) - (setf data (funcall pass data)) - (cl-loop for f in (alist-get pass comp-post-pass-hooks) - do (funcall f data)))) - comp-passes) + (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-error ;; Add source input. (let ((err-val (cdr err))) commit 79b9a262ffab37296a39c2d69cdabae153db10a7 Author: Omar Polo Date: Tue Jan 12 21:27:11 2021 +0100 * configure.ac: Fix native-comp OpenBSD build. diff --git a/configure.ac b/configure.ac index 1f9fd330a3..2a4a373371 100644 --- a/configure.ac +++ b/configure.ac @@ -3825,10 +3825,15 @@ if test "${with_nativecomp}" != "no"; then AC_RUN_IFELSE([libgccjit_smoke_test], [], [libgccjit_broken]) LIBS=$emacs_save_LIBS HAVE_NATIVE_COMP=yes - # mingw32 loads the library dynamically. - if test "${opsys}" != "mingw32"; then - LIBGCCJIT_LIB="-lgccjit -ldl" - fi + case "${opsys}" in + # mingw32 loads the library dynamically. + mingw32) ;; + # OpenBSD doesn't have libdl, all the functions are in libc + openbsd) + LIBGCCJIT_LIB="-lgccjit" ;; + *) + LIBGCCJIT_LIB="-lgccjit -ldl" ;; + esac NEED_DYNLIB=yes AC_DEFINE(HAVE_NATIVE_COMP, 1, [Define to 1 if native compiler is available.]) fi commit 42ff68ec2f1149704da59fd692fafb095a44cce2 Author: Andrea Corallo Date: Sat Jan 9 12:24:15 2021 +0100 Improve `comp-libgccjit-reproducer' * src/comp.c (Fcomp__compile_ctxt_to_file): Better libgccjit reproducer file name. * lisp/emacs-lisp/comp.el (comp-libgccjit-reproducer): Doc update. (comp-final, comp-run-async-workers): Pass `comp-libgccjit-reproducer' setting to child workers. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 79cf942e89..d5ca3b0004 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -138,8 +138,8 @@ and above." (defcustom comp-libgccjit-reproducer nil "When non-nil produce a libgccjit reproducer. -The reproducer is a file comp_SRCNAME_repro.c deposed in the .eln -output directory." +The reproducer is a file ELNFILENAME_libgccjit_repro.c deposed in +the .eln output directory." :type 'boolean) (defvar comp-dry-run nil @@ -3543,6 +3543,7 @@ Prepare every function for final compilation and drive the C back-end." (expr `(progn (require 'comp) (setf comp-verbose ,comp-verbose + comp-libgccjit-reproducer ,comp-libgccjit-reproducer comp-ctxt ,comp-ctxt comp-eln-load-path ',comp-eln-load-path comp-native-driver-options @@ -3795,6 +3796,7 @@ display a message." (setf comp-speed ,comp-speed comp-debug ,comp-debug comp-verbose ,comp-verbose + comp-libgccjit-reproducer ,comp-libgccjit-reproducer comp-async-compilation t comp-eln-load-path ',comp-eln-load-path comp-native-driver-options diff --git a/src/comp.c b/src/comp.c index f6445a7621..619f5e1b65 100644 --- a/src/comp.c +++ b/src/comp.c @@ -4431,7 +4431,7 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, if (!NILP (Fsymbol_value (Qcomp_libgccjit_reproducer))) gcc_jit_context_dump_reproducer_to_file ( comp.ctxt, - format_string ("comp_%s_repro.c", SSDATA (base_name))); + format_string ("%s_libgccjit_repro.c", SSDATA (base_name))); Lisp_Object tmp_file = Fmake_temp_file_internal (base_name, Qnil, build_string (".eln.tmp"), Qnil); commit 325c0765dfa4ef363d4f29650568bdafce0f0971 Author: Andrea Corallo Date: Fri Jan 8 00:44:55 2021 +0100 Add new customize `comp-libgccjit-reproducer' * lisp/emacs-lisp/comp.el (comp-libgccjit-reproducer): New customize. * src/comp.c (Fcomp__compile_ctxt_to_file): Use `comp-libgccjit-reproducer' for dumping repoducer. (syms_of_comp): Define 'Qcomp_libgccjit_reproducer'. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index d1953b59f0..79cf942e89 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -136,6 +136,12 @@ Passing these options is only available in libgccjit version 9 and above." :type 'list) +(defcustom comp-libgccjit-reproducer nil + "When non-nil produce a libgccjit reproducer. +The reproducer is a file comp_SRCNAME_repro.c deposed in the .eln +output directory." + :type 'boolean) + (defvar comp-dry-run nil "If non-nil, run everything but the C back-end.") diff --git a/src/comp.c b/src/comp.c index 2670c917ed..f6445a7621 100644 --- a/src/comp.c +++ b/src/comp.c @@ -4428,8 +4428,10 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, gcc_jit_context_dump_to_file (comp.ctxt, format_string ("%s.c", SSDATA (base_name)), 1); - if (comp.debug > 2) - gcc_jit_context_dump_reproducer_to_file (comp.ctxt, "comp_reproducer.c"); + if (!NILP (Fsymbol_value (Qcomp_libgccjit_reproducer))) + gcc_jit_context_dump_reproducer_to_file ( + comp.ctxt, + format_string ("comp_%s_repro.c", SSDATA (base_name))); Lisp_Object tmp_file = Fmake_temp_file_internal (base_name, Qnil, build_string (".eln.tmp"), Qnil); @@ -5099,6 +5101,7 @@ compiled one. */); DEFSYM (Qcomp_speed, "comp-speed"); DEFSYM (Qcomp_debug, "comp-debug"); DEFSYM (Qcomp_native_driver_options, "comp-native-driver-options"); + DEFSYM (Qcomp_libgccjit_reproducer, "comp-libgccjit-reproducer"); /* Limple instruction set. */ DEFSYM (Qcomment, "comment"); commit 400f620f24b90540f71673a998c41327237330be Merge: 213b5d7315 a31bfd5945 Author: Andrea Corallo Date: Fri Jan 8 21:40:45 2021 +0100 Merge remote-tracking branch 'savannah/master' into HEAD commit 213b5d73159cafbdd52b9c0fb0479544cca98a77 Author: Andrea Corallo Date: Thu Jan 7 23:10:18 2021 +0100 * lisp/emacs-lisp/comp.el (comp-known-type-specifiers): Fix typo. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 88b6a4690d..d1953b59f0 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -410,7 +410,7 @@ Useful to hook into pass checkers.") (radians-to-degrees (function (number) float)) (rassoc (function (t list) list)) (rassq (function (t list) list)) - (read-from-string (function (string &ptional integer integer) cons)) + (read-from-string (function (string &optional integer integer) cons)) (recent-keys (function (&optional (or cons null)) vector)) (recursion-depth (function () integer)) (regexp-opt (function (list) string)) commit ad0d553e8f8ddc8cb821944b043cfaec75dbb104 Author: Andrea Corallo Date: Mon Jan 4 22:45:42 2021 +0100 * Add a type specifier test * test/lisp/emacs-lisp/comp-cstr-tests.el (comp-cstr-typespec-tests-alist): Add testcase. diff --git a/test/lisp/emacs-lisp/comp-cstr-tests.el b/test/lisp/emacs-lisp/comp-cstr-tests.el index f5ed05244d..b4db54666c 100644 --- a/test/lisp/emacs-lisp/comp-cstr-tests.el +++ b/test/lisp/emacs-lisp/comp-cstr-tests.el @@ -209,7 +209,9 @@ ;; 84 ((not nil) . t) ;; 85 - ((or (not string) t) . t)) + ((or (not string) t) . t) + ;; 86 + ((or (not vector) sequence) . sequence)) "Alist type specifier -> expected type specifier.")) (defmacro comp-cstr-synthesize-tests () commit 33b8ce865fcfd58538ae2d7c3fff04998fcd3330 Author: Andrea Corallo Date: Wed Jan 6 15:26:38 2021 +0100 Fix bug#45603 Reported and reduced by Mauricio Collares. * lisp/emacs-lisp/comp.el (comp-final): Fix coding system for the tmp file used to pass data the child processes. * test/src/comp-tests.el (45603-1): New testcase * test/src/comp-test-45603.el : New File. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 3247b19c5e..88b6a4690d 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -3550,6 +3550,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 (prin1-to-string expr))) (with-temp-buffer (unwind-protect diff --git a/test/src/comp-test-45603.el b/test/src/comp-test-45603.el new file mode 100644 index 0000000000..f1c0dafb68 --- /dev/null +++ b/test/src/comp-test-45603.el @@ -0,0 +1,28 @@ +;;; -*- lexical-binding: t; -*- + +;; Reduced from ivy.el. + +(defvar comp-test-45603-last) +(defvar comp-test-45603-mark-prefix) +(defvar comp-test-45603-directory) +(defvar comp-test-45603-marked-candidates) + +(defun comp-test-45603--call-marked (action) + (let* ((prefix-len (length comp-test-45603-mark-prefix)) + (marked-candidates + (mapcar + (lambda (s) + (let ((cand (substring s prefix-len))) + (if comp-test-45603-directory + (expand-file-name cand comp-test-45603-directory) + cand))) + comp-test-45603-marked-candidates)) + (multi-action (comp-test-45603--get-multi-action comp-test-45603-last))))) + +(defalias 'comp-test-45603--file-local-name + (if (fboundp 'file-local-name) + #'file-local-name + (lambda (file) + (or (file-remote-p file 'localname) file)))) + +(provide 'comp-test-45603) diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 19e0940db8..c0325a8d5d 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -492,6 +492,11 @@ https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-03/msg00914.html." (should (string= (comp-test-45635-f :height 180 :family "PragmataPro Liga") "PragmataPro Liga"))) +(comp-deftest 45603-1 () + "" + (load (native-compile (concat comp-test-directory "comp-test-45603.el"))) + (should (fboundp #'comp-test-45603--file-local-name))) + ;;;;;;;;;;;;;;;;;;;;; ;; Tromey's tests. ;; commit 8ad983c4acef60a80e8d6b6ba891b1ef957f2d7c Author: Andrea Corallo Date: Mon Jan 4 22:16:07 2021 +0100 * test/src/comp-tests.el (cond-rw-1, not-cons, 45576): Rename three tests. diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 23a108796b..19e0940db8 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -475,14 +475,14 @@ https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-03/msg00914.html." '(1 2 3 (4 5 6)))) (should (null (comp-test-copy-insn-f nil)))) -(comp-deftest comp-test-cond-rw-1 () +(comp-deftest cond-rw-1 () "Check cond-rw does not break target blocks with multiple predecessor." (should (null (comp-test-cond-rw-1-2-f)))) -(comp-deftest comp-test-not-cons () +(comp-deftest not-cons-1 () (should-not (comp-test-not-cons-f nil))) -(comp-deftest comp-test-45576 () +(comp-deftest 45576-1 () "Functionp satisfies also symbols. ." (should (eq (comp-test-45576-f) 'eval))) commit 7293c23d14ed96cc07eeb87f0d974dcc25dcfa98 Author: Andrea Corallo Date: Mon Jan 4 22:14:50 2021 +0100 * Fix a type specifier test * test/lisp/emacs-lisp/comp-cstr-tests.el (comp-cstr-typespec-tests-alist): Fix a testcase. diff --git a/test/lisp/emacs-lisp/comp-cstr-tests.el b/test/lisp/emacs-lisp/comp-cstr-tests.el index 149afaf85d..f5ed05244d 100644 --- a/test/lisp/emacs-lisp/comp-cstr-tests.el +++ b/test/lisp/emacs-lisp/comp-cstr-tests.el @@ -103,7 +103,7 @@ ;; 30 ((and (member foo) (integer 1 2)) . nil) ;; 31 - ((and (member 1 2) (member 3 2)) . (member 2)) + ((and (member 1 2) (member 3 2)) . (integer 2 2)) ;; 32 ((and number (integer 1 2)) . (integer 1 2)) ;; 33 commit 5074447ef4980e2eb613e908e346fd3471f52139 Author: Andrea Corallo Date: Mon Jan 4 22:04:29 2021 +0100 Fix type inference for bug#45635 * lisp/emacs-lisp/comp-cstr.el (comp-cstr-union-1-no-mem): Fix missing mixed pos neg handling. * test/lisp/emacs-lisp/comp-cstr-tests.el (comp-cstr-typespec-tests-alist): Add a test. * test/src/comp-tests.el (45635): New testcase. * test/src/comp-test-funcs.el (comp-test-45635-f): New function. diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el index e63afa16a2..651c7b7931 100644 --- a/lisp/emacs-lisp/comp-cstr.el +++ b/lisp/emacs-lisp/comp-cstr.el @@ -558,6 +558,22 @@ DST is returned." ;; "simple" for now. (give-up)) + ;; When every neg type is a subtype of some pos one. + ;; In case return pos. + (when (and (typeset neg) + (cl-every (lambda (x) + (cl-some (lambda (y) + (comp-subtype-p x y)) + (append (typeset pos) + (when (range pos) + '(integer))))) + (typeset neg))) + (setf (typeset dst) (typeset pos) + (valset dst) (valset pos) + (range dst) (range pos) + (neg dst) nil) + (cl-return-from comp-cstr-union-1-no-mem dst)) + ;; Verify disjoint condition between positive types and ;; negative types coming from values, in case give-up. (let ((neg-value-types (nconc (mapcar #'type-of (valset neg)) diff --git a/test/lisp/emacs-lisp/comp-cstr-tests.el b/test/lisp/emacs-lisp/comp-cstr-tests.el index 1e1376b363..149afaf85d 100644 --- a/test/lisp/emacs-lisp/comp-cstr-tests.el +++ b/test/lisp/emacs-lisp/comp-cstr-tests.el @@ -207,7 +207,9 @@ ;; 83 ((not t) . nil) ;; 84 - ((not nil) . t)) + ((not nil) . t) + ;; 85 + ((or (not string) t) . t)) "Alist type specifier -> expected type specifier.")) (defmacro comp-cstr-synthesize-tests () diff --git a/test/src/comp-test-funcs.el b/test/src/comp-test-funcs.el index d0ec636581..694d9d426d 100644 --- a/test/src/comp-test-funcs.el +++ b/test/src/comp-test-funcs.el @@ -463,6 +463,21 @@ eshell-term eshell-unix)) sym))) +(defun comp-test-45635-f (&rest args) + ;; Reduced from `set-face-attribute'. + (let ((spec args) + family) + (while spec + (cond ((eq (car spec) :family) + (setq family (cadr spec)))) + (setq spec (cddr spec))) + (when (and (stringp family) + (string-match "\\([^-]*\\)-\\([^-]*\\)" family)) + (setq family (match-string 2 family))) + (when (or (stringp family) + (eq family 'unspecified)) + family))) + ;;;;;;;;;;;;;;;;;;;; ;; Tromey's tests ;; diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index faaa2f4e4f..23a108796b 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -487,6 +487,11 @@ https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-03/msg00914.html." ." (should (eq (comp-test-45576-f) 'eval))) +(comp-deftest 45635-1 () + "." + (should (string= (comp-test-45635-f :height 180 :family "PragmataPro Liga") + "PragmataPro Liga"))) + ;;;;;;;;;;;;;;;;;;;;; ;; Tromey's tests. ;; commit a3f2373bfb604af5570c86b4ffefb23296a5bfdd Author: Andrea Corallo Date: Sat Jan 2 13:22:30 2021 +0100 * lisp/emacs-lisp/comp.el (comp-known-predicates): Some more tweaking. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 455fd72efc..3247b19c5e 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -503,15 +503,15 @@ Useful to hook into pass checkers.") (defconst comp-known-predicates '((arrayp . array) (atom . atom) - (characterp . base-char) + (characterp . fixnum) (booleanp . boolean) (bool-vector-p . bool-vector) (bufferp . buffer) - (natnump . character) + (natnump . (integer 0 *)) (char-table-p . char-table) (hash-table-p . hash-table) (consp . cons) - (integerp . fixnum) + (integerp . integer) (floatp . float) (functionp . (or function symbol)) (integerp . integer) @@ -519,7 +519,7 @@ Useful to hook into pass checkers.") (listp . list) (numberp . number) (null . null) - (numberp . real) + (numberp . number) (sequencep . sequence) (stringp . string) (symbolp . symbol) commit 43d0e8483e5b51aec1347b8a2ed53acae34a9811 Author: Andrea Corallo Date: Sat Jan 2 12:18:39 2021 +0100 Fix `functionp' contraining (bug#45576) * lisp/emacs-lisp/comp.el (comp-known-predicates) (comp-known-predicates-h): New constants. (comp-known-predicate-p, comp-pred-to-cstr): New functions. * lisp/emacs-lisp/cl-macs.el (cl-deftype-satisfies): Don't define. * test/src/comp-tests.el (comp-test-45576): New testcase. * test/src/comp-test-funcs.el (comp-test-45576-f): New function. diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index 664d865cff..ac7360b935 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -3199,8 +3199,7 @@ Of course, we really can't know that for sure, so it's just a heuristic." ;; FIXME: Do we really want to consider this a type? (integer-or-marker . integer-or-marker-p) )) - (put type 'cl-deftype-satisfies pred) - (put pred 'cl-satisfies-deftype type)) + (put type 'cl-deftype-satisfies pred)) ;;;###autoload (define-inline cl-typep (val type) diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el index a53372be00..e63afa16a2 100644 --- a/lisp/emacs-lisp/comp-cstr.el +++ b/lisp/emacs-lisp/comp-cstr.el @@ -2,7 +2,7 @@ ;; Author: Andrea Corallo -;; Copyright (C) 2020 Free Software Foundation, Inc. +;; Copyright (C) 2020-2021 Free Software Foundation, Inc. ;; Keywords: lisp ;; Package: emacs @@ -179,10 +179,6 @@ Return them as multiple value." (defvar comp-cstr-one (comp-value-to-cstr 1) "Represent the integer immediate one.") -(defun comp-pred-to-cstr (predicate) - "Given PREDICATE return the correspondig constraint." - (comp-type-to-cstr (get predicate 'cl-satisfies-deftype))) - ;;; Value handling. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index ab3763f5ed..455fd72efc 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -500,6 +500,51 @@ Useful to hook into pass checkers.") finally return h) "Hash table function -> `comp-constraint'") +(defconst comp-known-predicates + '((arrayp . array) + (atom . atom) + (characterp . base-char) + (booleanp . boolean) + (bool-vector-p . bool-vector) + (bufferp . buffer) + (natnump . character) + (char-table-p . char-table) + (hash-table-p . hash-table) + (consp . cons) + (integerp . fixnum) + (floatp . float) + (functionp . (or function symbol)) + (integerp . integer) + (keywordp . keyword) + (listp . list) + (numberp . number) + (null . null) + (numberp . real) + (sequencep . sequence) + (stringp . string) + (symbolp . symbol) + (vectorp . vector) + (integer-or-marker-p . integer-or-marker)) + "Alist predicate -> matched type specifier.") + +(defconst comp-known-predicates-h + (cl-loop + with comp-ctxt = (make-comp-cstr-ctxt) + with h = (make-hash-table :test #'eq) + for (pred . type-spec) in comp-known-predicates + for cstr = (comp-type-spec-to-cstr type-spec) + do (puthash pred cstr h) + finally return h) + "Hash table function -> `comp-constraint'") + +(defun comp-known-predicate-p (predicate) + "Predicate matching if PREDICATE is known." + (when (gethash predicate comp-known-predicates-h) t)) + +(defun comp-pred-to-cstr (predicate) + "Given PREDICATE return the correspondig constraint." + (gethash predicate comp-known-predicates-h)) + (defconst comp-symbol-values-optimizable '(most-positive-fixnum most-negative-fixnum) "Symbol values we can resolve in the compile-time.") @@ -2329,10 +2374,6 @@ TARGET-BB-SYM is the symbol name of the target block." (comp-emit-assume 'and obj1 obj2 block-target negated)) finally (cl-return-from in-the-basic-block))))))) -(defun comp-known-predicate-p (pred) - (when (symbolp pred) - (get pred 'cl-satisfies-deftype))) - (defun comp-add-cond-cstrs () "`comp-add-cstrs' worker function for each selected function." (cl-loop diff --git a/test/src/comp-test-funcs.el b/test/src/comp-test-funcs.el index 1c2fb3d3c0..d0ec636581 100644 --- a/test/src/comp-test-funcs.el +++ b/test/src/comp-test-funcs.el @@ -455,6 +455,14 @@ (print x) (car x))) +(defun comp-test-45576-f () + ;; Reduced from `eshell-find-alias-function'. + (let ((sym (intern-soft "eval"))) + (if (and (functionp sym) + '(eshell-ls eshell-pred eshell-prompt eshell-script + eshell-term eshell-unix)) + sym))) + ;;;;;;;;;;;;;;;;;;;; ;; Tromey's tests ;; diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 9801136152..faaa2f4e4f 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -482,6 +482,11 @@ https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-03/msg00914.html." (comp-deftest comp-test-not-cons () (should-not (comp-test-not-cons-f nil))) +(comp-deftest comp-test-45576 () + "Functionp satisfies also symbols. +." + (should (eq (comp-test-45576-f) 'eval))) + ;;;;;;;;;;;;;;;;;;;;; ;; Tromey's tests. ;; commit 03be03d36636626d4c45acd76e2f2d36be02ec8c Author: Andrea Corallo Date: Sat Jan 2 11:30:10 2021 +0100 * Rename `dom' slot into `idom' in `comp-block' struct * lisp/emacs-lisp/comp.el (comp-block): Rename dom `slot' into `idom'. (comp-clean-ssa, comp-compute-dominator-tree) (comp-compute-dominator-frontiers, comp-dom-tree-walker) (comp-remove-unreachable-blocks): Update accordingly. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 340846bf70..ab3763f5ed 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -627,7 +627,7 @@ This is typically for top-level forms other than defun.") :documentation "List of incoming edges.") (out-edges () :type list :documentation "List of out-coming edges.") - (dom nil :type (or null comp-block) + (idom nil :type (or null comp-block) :documentation "Immediate dominator.") (df (make-hash-table) :type (or null hash-table) :documentation "Dominance frontier set. Block-name -> block") @@ -2568,7 +2568,7 @@ blocks." for b being each hash-value of (comp-func-blocks f) do (setf (comp-block-in-edges b) () (comp-block-out-edges b) () - (comp-block-dom b) nil + (comp-block-idom b) nil (comp-block-df b) (make-hash-table) (comp-block-post-num b) nil (comp-block-final-frame b) nil @@ -2637,14 +2637,14 @@ blocks." (finger2 (comp-block-post-num b2))) (while (not (= finger1 finger2)) (while (< finger1 finger2) - (setf b1 (comp-block-dom b1) + (setf b1 (comp-block-idom b1) finger1 (comp-block-post-num b1))) (while (< finger2 finger1) - (setf b2 (comp-block-dom b2) + (setf b2 (comp-block-idom b2) finger2 (comp-block-post-num b2)))) b1)) (first-processed (l) - (if-let ((p (cl-find-if (lambda (p) (comp-block-dom p)) l))) + (if-let ((p (cl-find-if (lambda (p) (comp-block-idom p)) l))) p (signal 'native-ice "cant't find first preprocessed")))) @@ -2658,7 +2658,7 @@ blocks." while changed initially (progn (comp-log "Computing dominator tree...\n" 2) - (setf (comp-block-dom entry) entry) + (setf (comp-block-idom entry) entry) ;; Set the post order number. (cl-loop for name in (reverse rev-bb-list) for b = (gethash name blocks) @@ -2671,10 +2671,10 @@ blocks." for new-idom = (first-processed preds) initially (setf changed nil) do (cl-loop for p in (delq new-idom preds) - when (comp-block-dom p) + when (comp-block-idom p) do (setf new-idom (intersect p new-idom))) - unless (eq (comp-block-dom b) new-idom) - do (setf (comp-block-dom b) (unless (and (comp-block-lap-p new-idom) + unless (eq (comp-block-idom b) new-idom) + do (setf (comp-block-idom b) (unless (and (comp-block-lap-p new-idom) (comp-block-lap-no-ret new-idom)) new-idom) @@ -2691,14 +2691,14 @@ blocks." when (>= (length preds) 2) ; All joins do (cl-loop for p in preds for runner = p - do (while (not (eq runner (comp-block-dom b))) + do (while (not (eq runner (comp-block-idom b))) (puthash b-name b (comp-block-df runner)) - (setf runner (comp-block-dom runner)))))) + (setf runner (comp-block-idom runner)))))) (defun comp-log-block-info () "Log basic blocks info for the current function." (maphash (lambda (name bb) - (let ((dom (comp-block-dom bb)) + (let ((dom (comp-block-idom bb)) (df (comp-block-df bb))) (comp-log (format "block: %s idom: %s DF %s\n" name @@ -2756,7 +2756,7 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non-nil." (when-let ((out-edges (comp-block-out-edges bb))) (cl-loop for ed in out-edges for child = (comp-edge-dst ed) - when (eq bb (comp-block-dom child)) + when (eq bb (comp-block-idom child)) ;; Current block is the immediate dominator then recur. do (comp-dom-tree-walker child pre-lambda post-lambda))) (when post-lambda @@ -2840,7 +2840,7 @@ Return t when one or more block was removed, nil otherwise." for bb being each hash-value of (comp-func-blocks comp-func) for bb-name = (comp-block-name bb) when (and (not (eq 'entry bb-name)) - (null (comp-block-dom bb))) + (null (comp-block-idom bb))) do (comp-log (format "Removing block: %s" bb-name) 1) (remhash bb-name (comp-func-blocks comp-func)) commit 5db5064395c251a822e429e19ddecb74a974b6ef Merge: 9420ea6e08 0f561ee553 Author: Andrea Corallo Date: Sat Jan 2 10:11:15 2021 +0100 Merge remote-tracking branch 'savannah/master' into HEAD commit 9420ea6e0840bffcb140d3677dfdabb9251c1f63 Author: Andrea Corallo Date: Fri Jan 1 14:13:02 2021 +0100 Add `throw' to non returning functions * lisp/emacs-lisp/comp.el (comp-known-type-specifiers): Add throw. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 9fea345135..340846bf70 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2,7 +2,7 @@ ;; Author: Andrea Corallo -;; Copyright (C) 2019-2020 Free Software Foundation, Inc. +;; Copyright (C) 2019-2021 Free Software Foundation, Inc. ;; Keywords: lisp ;; Package: emacs @@ -485,6 +485,7 @@ Useful to hook into pass checkers.") (comp-hint-fixnum (function (t) fixnum)) (comp-hint-cons (function (t) cons)) ;; Non returning functions + (throw (function (t t) nil)) (error (function (string &rest t) nil)) (signal (function (symbol t) nil))) "Alist used for type propagation.") commit 807471f9ffd303048140175932cf6b1e09eb7652 Author: Andrea Corallo Date: Fri Jan 1 13:53:08 2021 +0100 ; * lisp/emacs-lisp/comp.el (comp-compute-dominator-tree): Reindent. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 848bcf70cd..9fea345135 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2651,31 +2651,33 @@ blocks." (entry (gethash 'entry blocks)) ;; No point to go on if the only bb is 'entry'. (bb0 (gethash 'bb_0 blocks))) - (cl-loop with rev-bb-list = (comp-collect-rev-post-order entry) - with changed = t - while changed - initially (progn - (comp-log "Computing dominator tree...\n" 2) - (setf (comp-block-dom entry) entry) - ;; Set the post order number. - (cl-loop for name in (reverse rev-bb-list) - for b = (gethash name blocks) - for i from 0 - do (setf (comp-block-post-num b) i))) - do (cl-loop - for name in (cdr rev-bb-list) - for b = (gethash name blocks) - for preds = (comp-block-preds b) - for new-idom = (first-processed preds) - initially (setf changed nil) - do (cl-loop for p in (delq new-idom preds) - when (comp-block-dom p) - do (setf new-idom (intersect p new-idom))) - unless (eq (comp-block-dom b) new-idom) - do (setf (comp-block-dom b) (unless (and (comp-block-lap-p new-idom) - (comp-block-lap-no-ret new-idom)) - new-idom) - changed t)))))) + (cl-loop + with rev-bb-list = (comp-collect-rev-post-order entry) + with changed = t + while changed + initially (progn + (comp-log "Computing dominator tree...\n" 2) + (setf (comp-block-dom entry) entry) + ;; Set the post order number. + (cl-loop for name in (reverse rev-bb-list) + for b = (gethash name blocks) + for i from 0 + do (setf (comp-block-post-num b) i))) + do (cl-loop + for name in (cdr rev-bb-list) + for b = (gethash name blocks) + for preds = (comp-block-preds b) + for new-idom = (first-processed preds) + initially (setf changed nil) + do (cl-loop for p in (delq new-idom preds) + when (comp-block-dom p) + do (setf new-idom (intersect p new-idom))) + unless (eq (comp-block-dom b) new-idom) + do (setf (comp-block-dom b) (unless (and (comp-block-lap-p new-idom) + (comp-block-lap-no-ret + new-idom)) + new-idom) + changed t)))))) (defun comp-compute-dominator-frontiers () "Compute the dominator frontier for each basic block in `comp-func'." commit c29037c877ae0d606daf3949dfc3e4e43883d74f Author: Andrea Corallo Date: Fri Jan 1 12:00:04 2021 +0100 * lisp/emacs-lisp/comp.el (comp-compute-dominator-tree): Fix. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 227333f72c..848bcf70cd 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2650,7 +2650,7 @@ blocks." (when-let ((blocks (comp-func-blocks comp-func)) (entry (gethash 'entry blocks)) ;; No point to go on if the only bb is 'entry'. - (bb1 (gethash 'bb_1 blocks))) + (bb0 (gethash 'bb_0 blocks))) (cl-loop with rev-bb-list = (comp-collect-rev-post-order entry) with changed = t while changed commit 93ff838575d25eba76bb0b3d476a36a56bbfba30 Author: Andrea Corallo Date: Fri Jan 1 11:09:00 2021 +0100 * Clean unreachable block using dominance tree to handle circularities With this commit unreachable basic blocks are pruned automatically by comp-ssa relying on dominance analysis. This solves the issue of unreachable cluster of basic blocks referencing each other. * lisp/emacs-lisp/comp.el (comp-block-lap): New `no-ret' slot. (comp-compute-dominator-tree): Update. (comp-remove-unreachable-blocks): New functions. (comp-ssa): Update to call `comp-remove-unreachable-blocks'. (comp-clean-orphan-blocks): Delete. (comp-rewrite-non-locals): Update and simplify. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 3ef9a6be73..227333f72c 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -648,9 +648,12 @@ into it.") (addr nil :type number :documentation "Start block LAP address.") (non-ret-insn nil :type list - :documentation "Non returning basic blocks. + :documentation "Insn known to perform a non local exit. `comp-fwprop' may identify and store here basic blocks performing -non local exits.")) +non local exits and mark it rewrite it later.") + (no-ret nil :type boolean + :documentation "t when the block is known to perform a +non local exit (ends with an `unreachable' insn).")) (cl-defstruct (comp-latch (:copier nil) (:include comp-block)) @@ -2669,7 +2672,9 @@ blocks." when (comp-block-dom p) do (setf new-idom (intersect p new-idom))) unless (eq (comp-block-dom b) new-idom) - do (setf (comp-block-dom b) new-idom + do (setf (comp-block-dom b) (unless (and (comp-block-lap-p new-idom) + (comp-block-lap-no-ret new-idom)) + new-idom) changed t)))))) (defun comp-compute-dominator-frontiers () @@ -2824,16 +2829,34 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non-nil." when (eq op 'phi) do (finalize-phi args b))))) +(defun comp-remove-unreachable-blocks () + "Remove unreachable basic blocks. +Return t when one or more block was removed, nil otherwise." + (cl-loop + with ret + for bb being each hash-value of (comp-func-blocks comp-func) + for bb-name = (comp-block-name bb) + when (and (not (eq 'entry bb-name)) + (null (comp-block-dom bb))) + do + (comp-log (format "Removing block: %s" bb-name) 1) + (remhash bb-name (comp-func-blocks comp-func)) + (setf (comp-func-ssa-status comp-func) t + ret t) + finally return ret)) + (defun comp-ssa () "Port all functions into minimal SSA form." (maphash (lambda (_ f) (let* ((comp-func f) (ssa-status (comp-func-ssa-status f))) (unless (eq ssa-status t) - (when (eq ssa-status 'dirty) - (comp-clean-ssa f)) - (comp-compute-edges) - (comp-compute-dominator-tree) + (cl-loop + when (eq ssa-status 'dirty) + do (comp-clean-ssa f) + do (comp-compute-edges) + (comp-compute-dominator-tree) + until (null (comp-remove-unreachable-blocks))) (comp-compute-dominator-frontiers) (comp-log-block-info) (comp-place-phis) @@ -3023,25 +3046,6 @@ Return t if something was changed." do (setf modified t)) finally return modified)) -(defun comp-clean-orphan-blocks (block) - "Iterativelly remove all non reachable blocks orphaned by BLOCK." - (while - (cl-loop - with repeat = nil - with blocks = (comp-func-blocks comp-func) - for bb being each hash-value of blocks - when (and (not (eq (comp-block-name bb) 'entry)) - (cl-notany (lambda (ed) - (and (gethash (comp-block-name (comp-edge-src ed)) - blocks) - (not (eq (comp-edge-src ed) block)))) - (comp-block-in-edges bb))) - do - (comp-log (format "Removing block: %s" (comp-block-name bb)) 1) - (remhash (comp-block-name bb) blocks) - (setf repeat t) - finally return repeat))) - (defun comp-rewrite-non-locals () "Make explicit in LIMPLE non-local exits if identified." (cl-loop @@ -3050,18 +3054,10 @@ Return t if something was changed." (comp-block-lap-non-ret-insn bb)) when non-local-insn do - (cl-loop - for ed in (comp-block-out-edges bb) - for dst-bb = (comp-edge-dst ed) - ;; Remove one or more block if necessary. - when (length= (comp-block-in-edges dst-bb) 1) - do - (comp-log (format "Removing block: %s" (comp-block-name dst-bb)) 1) - (remhash (comp-block-name dst-bb) (comp-func-blocks comp-func)) - (comp-clean-orphan-blocks bb)) ;; Rework the current block. (let* ((insn-seq (memq non-local-insn (comp-block-insns bb)))) (setf (comp-block-lap-non-ret-insn bb) () + (comp-block-lap-no-ret bb) t (comp-block-out-edges bb) () ;; Prune unnecessary insns! (cdr insn-seq) '((unreachable)) commit 6ba94f7c77b4013e15f8a5a9181fba9a2df20ab7 Author: Andrea Corallo Date: Fri Jan 1 12:27:39 2021 +0100 * src/comp.c (Fcomp__compile_ctxt_to_file): Fix hash table iteration. diff --git a/src/comp.c b/src/comp.c index da4361030b..2670c917ed 100644 --- a/src/comp.c +++ b/src/comp.c @@ -4413,12 +4413,14 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, struct Lisp_Hash_Table *func_h = XHASH_TABLE (CALL1I (comp-ctxt-funcs-h, Vcomp_ctxt)); - for (ptrdiff_t i = 0; i < func_h->count; i++) - declare_function (HASH_VALUE (func_h, i)); + for (ptrdiff_t i = 0; i < HASH_TABLE_SIZE (func_h); i++) + if (!EQ (HASH_VALUE (func_h, i), Qunbound)) + declare_function (HASH_VALUE (func_h, i)); /* Compile all functions. Can't be done before because the relocation structs has to be already defined. */ - for (ptrdiff_t i = 0; i < func_h->count; i++) - compile_function (HASH_VALUE (func_h, i)); + for (ptrdiff_t i = 0; i < HASH_TABLE_SIZE (func_h); i++) + if (!EQ (HASH_VALUE (func_h, i), Qunbound)) + compile_function (HASH_VALUE (func_h, i)); add_driver_options (); commit 67c443adc1ef8a03d27c6172247e792421bb0e13 Author: Andrea Corallo Date: Thu Dec 31 17:37:13 2020 +0100 Introduce 'unreachable' LIMPLE operator Introduce 'unreachable' as LIMPLE operater so we can handle correctly in the CFG functions throwing values or signaling errors. * src/comp.c (retrive_block): Better error diagnostic. (emit_limple_insn): Add `unreachable'. (compile_function): Fix block iteration. (syms_of_comp): Define 'Qunreachable'. * lisp/emacs-lisp/comp.el (comp-block): New variable. (comp-block-lap): Add `non-ret-insn' slot. (comp-branch-op-p): New predicate. (comp-limple-lock-keywords): Color `unreachable' as red. (comp-compute-edges): Add `unreachable'. (comp-fwprop-call): Store non returning function call. (comp-fwprop*): Update. (comp-clean-orphan-blocks, comp-rewrite-non-locals): New functions. (comp-fwprop): Call `comp-rewrite-non-locals'. * test/src/comp-tests.el (comp-tests-type-spec-tests): Add two tests. * test/src/comp-test-funcs.el (comp-test-non-local-1) (comp-test-non-local-2, comp-test-non-local-3) (comp-test-non-local-4): New functions. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index a6704e8c18..3ef9a6be73 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -537,6 +537,9 @@ Useful to hook into pass checkers.") (defvar comp-func nil "Bound to the current function by most passes.") +(defvar comp-block nil + "Bound to the current basic block by some pass.") + (define-error 'native-compiler-error-dyn-func "can't native compile a non-lexically-scoped function" 'native-compiler-error) @@ -637,13 +640,17 @@ Is in use to help the SSA rename pass.")) (:include comp-block) (:constructor make--comp-block-lap (addr sp name))) ; Positional - "A basic block created from lap." + "A basic block created from lap (real code)." ;; These two slots are used during limplification. (sp nil :type number :documentation "When non-nil indicates the sp value while entering into it.") (addr nil :type number - :documentation "Start block LAP address.")) + :documentation "Start block LAP address.") + (non-ret-insn nil :type list + :documentation "Non returning basic blocks. +`comp-fwprop' may identify and store here basic blocks performing +non local exits.")) (cl-defstruct (comp-latch (:copier nil) (:include comp-block)) @@ -843,6 +850,10 @@ To be used by all entry points." "Call predicate for OP." (when (memq op comp-limple-calls) t)) +(defun comp-branch-op-p (op) + "Branch predicate for OP." + (when (memq op comp-limple-branches) t)) + (defsubst comp-limple-insn-call-p (insn) "Limple INSN call predicate." (comp-call-op-p (car-safe insn))) @@ -894,7 +905,7 @@ Assume allocation class 'd-default as default." (1 font-lock-function-name-face)) (,(rx bol "(" (group-n 1 "phi")) (1 font-lock-variable-name-face)) - (,(rx bol "(" (group-n 1 "return")) + (,(rx bol "(" (group-n 1 (or "return" "unreachable"))) (1 font-lock-warning-face)) (,(rx (group-n 1 (or "entry" (seq (or "entry_" "entry_fallback_" "bb_") @@ -2581,6 +2592,7 @@ blocks." (make-comp-edge :src bb :dst (gethash third blocks)) (make-comp-edge :src bb :dst (gethash forth blocks))) (return) + (unreachable) (otherwise (signal 'native-ice (list "block does not end with a branch" @@ -2936,6 +2948,9 @@ Fold the call in case." args (cdr args))) (when-let ((cstr-f (gethash f comp-known-func-cstr-h))) (let ((cstr (comp-cstr-f-ret cstr-f))) + (when (comp-cstr-empty-p cstr) + ;; Store it to be rewrittein 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) @@ -2997,15 +3012,61 @@ Fold the call in case." Return t if something was changed." (cl-loop with modified = nil for b being each hash-value of (comp-func-blocks comp-func) - do (cl-loop for insn in (comp-block-insns b) - for orig-insn = (unless modified - ;; Save consing after 1th change. - (comp-copy-insn insn)) - do (comp-fwprop-insn insn) - when (and (null modified) (not (equal insn orig-insn))) - do (setf modified t)) + do (cl-loop + with comp-block = b + for insn in (comp-block-insns b) + for orig-insn = (unless modified + ;; Save consing after 1th change. + (comp-copy-insn insn)) + do (comp-fwprop-insn insn) + when (and (null modified) (not (equal insn orig-insn))) + do (setf modified t)) finally return modified)) +(defun comp-clean-orphan-blocks (block) + "Iterativelly remove all non reachable blocks orphaned by BLOCK." + (while + (cl-loop + with repeat = nil + with blocks = (comp-func-blocks comp-func) + for bb being each hash-value of blocks + when (and (not (eq (comp-block-name bb) 'entry)) + (cl-notany (lambda (ed) + (and (gethash (comp-block-name (comp-edge-src ed)) + blocks) + (not (eq (comp-edge-src ed) block)))) + (comp-block-in-edges bb))) + do + (comp-log (format "Removing block: %s" (comp-block-name bb)) 1) + (remhash (comp-block-name bb) blocks) + (setf repeat t) + finally return repeat))) + +(defun comp-rewrite-non-locals () + "Make explicit in LIMPLE non-local exits if identified." + (cl-loop + for bb being each hash-value of (comp-func-blocks comp-func) + for non-local-insn = (and (comp-block-lap-p bb) + (comp-block-lap-non-ret-insn bb)) + when non-local-insn + do + (cl-loop + for ed in (comp-block-out-edges bb) + for dst-bb = (comp-edge-dst ed) + ;; Remove one or more block if necessary. + when (length= (comp-block-in-edges dst-bb) 1) + do + (comp-log (format "Removing block: %s" (comp-block-name dst-bb)) 1) + (remhash (comp-block-name dst-bb) (comp-func-blocks comp-func)) + (comp-clean-orphan-blocks bb)) + ;; Rework the current block. + (let* ((insn-seq (memq non-local-insn (comp-block-insns bb)))) + (setf (comp-block-lap-non-ret-insn bb) () + (comp-block-out-edges bb) () + ;; Prune unnecessary insns! + (cdr insn-seq) '((unreachable)) + (comp-func-ssa-status comp-func) 'dirty)))) + (defun comp-fwprop (_) "Forward propagate types and consts within the lattice." (comp-ssa) @@ -3024,6 +3085,7 @@ Return t if something was changed." 'comp (format "fwprop pass jammed into %s?" (comp-func-name f)))) (comp-log (format "Propagation run %d times\n" i) 2)) + (comp-rewrite-non-locals) (comp-log-func comp-func 3)))) (comp-ctxt-funcs-h comp-ctxt))) diff --git a/src/comp.c b/src/comp.c index 04bf9973d2..da4361030b 100644 --- a/src/comp.c +++ b/src/comp.c @@ -753,7 +753,7 @@ retrive_block (Lisp_Object block_name) Lisp_Object value = Fgethash (block_name, comp.func_blocks_h, Qnil); if (NILP (value)) - xsignal1 (Qnative_ice, build_string ("missing basic block")); + xsignal2 (Qnative_ice, build_string ("missing basic block"), block_name); return (gcc_jit_block *) xmint_pointer (value); } @@ -2282,6 +2282,13 @@ emit_limple_insn (Lisp_Object insn) NULL, emit_mvar_rval (arg[0])); } + else if (EQ (op, Qunreachable)) + { + /* Libgccjit has no __builtin_unreachable. */ + gcc_jit_block_end_with_return (comp.block, + NULL, + emit_lisp_obj_rval (Qnil)); + } else { xsignal2 (Qnative_ice, @@ -3910,13 +3917,13 @@ compile_function (Lisp_Object func) The "entry" block must be declared as first. */ declare_block (Qentry); Lisp_Object blocks = CALL1I (comp-func-blocks, func); - Lisp_Object entry_block = Fgethash (Qentry, blocks, Qnil); struct Lisp_Hash_Table *ht = XHASH_TABLE (blocks); - for (ptrdiff_t i = 0; i < ht->count; i++) + for (ptrdiff_t i = 0; i < HASH_TABLE_SIZE (ht); i++) { - Lisp_Object block = HASH_VALUE (ht, i); - if (!EQ (block, entry_block)) - declare_block (HASH_KEY (ht, i)); + Lisp_Object block_name = HASH_KEY (ht, i); + if (!EQ (block_name, Qentry) + && !EQ (block_name, Qunbound)) + declare_block (block_name); } gcc_jit_block_add_assignment (retrive_block (Qentry), @@ -3925,21 +3932,24 @@ compile_function (Lisp_Object func) gcc_jit_lvalue_as_rvalue (comp.func_relocs)); - for (ptrdiff_t i = 0; i < ht->count; i++) + for (ptrdiff_t i = 0; i < HASH_TABLE_SIZE (ht); i++) { Lisp_Object block_name = HASH_KEY (ht, i); - Lisp_Object block = HASH_VALUE (ht, i); - Lisp_Object insns = CALL1I (comp-block-insns, block); - if (NILP (block) || NILP (insns)) - xsignal1 (Qnative_ice, - build_string ("basic block is missing or empty")); - - comp.block = retrive_block (block_name); - while (CONSP (insns)) + if (!EQ (block_name, Qunbound)) { - Lisp_Object insn = XCAR (insns); - emit_limple_insn (insn); - insns = XCDR (insns); + Lisp_Object block = HASH_VALUE (ht, i); + Lisp_Object insns = CALL1I (comp-block-insns, block); + if (NILP (block) || NILP (insns)) + xsignal1 (Qnative_ice, + build_string ("basic block is missing or empty")); + + comp.block = retrive_block (block_name); + while (CONSP (insns)) + { + Lisp_Object insn = XCAR (insns); + emit_limple_insn (insn); + insns = XCDR (insns); + } } } const char *err = gcc_jit_context_get_first_error (comp.ctxt); @@ -5098,6 +5108,7 @@ compiled one. */); DEFSYM (Qassume, "assume"); DEFSYM (Qsetimm, "setimm"); DEFSYM (Qreturn, "return"); + DEFSYM (Qunreachable, "unreachable"); DEFSYM (Qcomp_mvar, "comp-mvar"); DEFSYM (Qcond_jump, "cond-jump"); DEFSYM (Qphi, "phi"); diff --git a/test/src/comp-test-funcs.el b/test/src/comp-test-funcs.el index 49e80763be..1c2fb3d3c0 100644 --- a/test/src/comp-test-funcs.el +++ b/test/src/comp-test-funcs.el @@ -621,6 +621,22 @@ (load (if (file-exists-p dest) dest filename))) 'no-byte-compile))) +(defun comp-test-no-return-1 (x) + (while x + (error "foo"))) + +(defun comp-test-no-return-2 (x) + (cond + ((eql x '2) t) + ((error "bar") nil))) + +(defun comp-test-no-return-3 ()) +(defun comp-test-no-return-4 (x) + (when x + (error "foo") + (while (comp-test-no-return-3) + (comp-test-no-return-3)))) + (provide 'comp-test-funcs) ;;; comp-test-funcs.el ends here diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 4546eccb62..9801136152 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -949,50 +949,50 @@ Return a list of results." ;; 22 ((defun comp-tests-ret-type-spec-f (x) - (when (> x 3) - x)) + (when (> x 3) + x)) (or null float (integer 4 *))) ;; 23 ((defun comp-tests-ret-type-spec-f (x) - (when (>= x 3) - x)) + (when (>= x 3) + x)) (or null float (integer 3 *))) ;; 24 ((defun comp-tests-ret-type-spec-f (x) - (when (< x 3) - x)) + (when (< x 3) + x)) (or null float (integer * 2))) ;; 25 ((defun comp-tests-ret-type-spec-f (x) - (when (<= x 3) - x)) + (when (<= x 3) + x)) (or null float (integer * 3))) ;; 26 ((defun comp-tests-ret-type-spec-f (x) - (when (> 3 x) - x)) + (when (> 3 x) + x)) (or null float (integer * 2))) ;; 27 ((defun comp-tests-ret-type-spec-f (x) - (when (>= 3 x) - x)) + (when (>= 3 x) + x)) (or null float (integer * 3))) ;; 28 ((defun comp-tests-ret-type-spec-f (x) - (when (< 3 x) - x)) + (when (< 3 x) + x)) (or null float (integer 4 *))) ;; 29 ((defun comp-tests-ret-type-spec-f (x) - (when (<= 3 x) - x)) + (when (<= 3 x) + x)) (or null float (integer 3 *))) ;; 30 @@ -1032,8 +1032,8 @@ Return a list of results." ;; 35 No float range support. ((defun comp-tests-ret-type-spec-f (x) - (when (> x 1.0) - x)) + (when (> x 1.0) + x)) (or null marker number)) ;; 36 @@ -1061,17 +1061,17 @@ Return a list of results." ;; 39 ;; SBCL gives: (OR REAL NULL) ((defun comp-tests-ret-type-spec-f (x y) - (when (and (<= 1 x 10) - (<= 2 y 3)) - (+ x y))) + (when (and (<= 1 x 10) + (<= 2 y 3)) + (+ x y))) (or null float (integer 3 13))) ;; 40 ;; SBCL: (OR REAL NULL) ((defun comp-tests-ret-type-spec-f (x y) - (when (and (<= 1 x 10) - (<= 2 y 3)) - (- x y))) + (when (and (<= 1 x 10) + (<= 2 y 3)) + (- x y))) (or null float (integer -2 8))) ;; 41 @@ -1090,23 +1090,23 @@ Return a list of results." ;; 43 ((defun comp-tests-ret-type-spec-f (x y) - (when (and (<= x 10) - (<= 2 y)) - (- x y))) + (when (and (<= x 10) + (<= 2 y)) + (- x y))) (or null float (integer * 8))) ;; 44 ((defun comp-tests-ret-type-spec-f (x y) - (when (and (<= x 10) - (<= y 3)) - (- x y))) + (when (and (<= x 10) + (<= y 3)) + (- x y))) (or null float integer)) ;; 45 ((defun comp-tests-ret-type-spec-f (x y) - (when (and (<= 2 x) - (<= 3 y)) - (- x y))) + (when (and (<= 2 x) + (<= 3 y)) + (- x y))) (or null float integer)) ;; 46 @@ -1176,7 +1176,27 @@ Return a list of results." ((defun comp-tests-ret-type-spec-f (x) (unless (integerp x) x)) - (not integer)))) + (not integer)) + + ;; 56 + ((defun comp-tests-ret-type-spec-f (x) + (cl-ecase x + (1 (message "one")) + (5 (message "five"))) + x) + t + ;; FIXME improve `comp-cond-cstrs-target-mvar' to cross block + ;; boundary if necessary as this should return: + ;; (or (integer 1 1) (integer 5 5)) + ) + + ;; 57 + ((defun comp-tests-ret-type-spec-f (x) + (unless (or (eq x 'foo) + (= x 3)) + (error "Not foo or 3")) + x) + (or (member foo) (integer 3 3))))) (defun comp-tests-define-type-spec-test (number x) `(comp-deftest ,(intern (format "ret-type-spec-%d" number)) () commit e9f5fadb0ecb64148472f846a99a0d7e95daeaee Author: Andrea Corallo Date: Thu Dec 31 15:32:51 2020 +0100 * Fix two predicates for missing negation handling * lisp/emacs-lisp/comp-cstr.el (comp-cstr-empty-p) (comp-cstr-null-p): Fix missing negation handling. diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el index c03056e3af..a53372be00 100644 --- a/lisp/emacs-lisp/comp-cstr.el +++ b/lisp/emacs-lisp/comp-cstr.el @@ -139,14 +139,16 @@ Integer values are handled in the `range' slot.") (with-comp-cstr-accessors (and (null (typeset cstr)) (null (valset cstr)) - (null (range cstr))))) + (null (range cstr)) + (null (neg cstr))))) -(defsubst comp-cstr-null-p (x) +(defsubst comp-cstr-null-p (cstr) "Return t if CSTR is equivalent to the `null' type specifier, nil otherwise." (with-comp-cstr-accessors - (and (null (typeset x)) - (null (range x)) - (equal (valset x) '(nil))))) + (and (null (typeset cstr)) + (null (range cstr)) + (null (neg cstr)) + (equal (valset cstr) '(nil))))) (defun comp-cstrs-homogeneous (cstrs) "Check if constraints CSTRS are all homogeneously negated or non-negated. commit f78580a0f5b913c60862d2ddedfc6b80e5cb4791 Author: Andrea Corallo Date: Thu Dec 31 15:27:24 2020 +0100 * lisp/emacs-lisp/comp.el (comp-limple-lock-keywords): Color returns as red. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index d7578fdcc0..a6704e8c18 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -894,6 +894,8 @@ Assume allocation class 'd-default as default." (1 font-lock-function-name-face)) (,(rx bol "(" (group-n 1 "phi")) (1 font-lock-variable-name-face)) + (,(rx bol "(" (group-n 1 "return")) + (1 font-lock-warning-face)) (,(rx (group-n 1 (or "entry" (seq (or "entry_" "entry_fallback_" "bb_") (1+ num) (? (or "_latch" commit e81643bef500e1f1ec49d152f7db1ffc5a74ecd5 Author: Andrea Corallo Date: Thu Dec 31 11:27:53 2020 +0100 * Add `comp-insert-insn' * lisp/emacs-lisp/comp.el (comp-insert-insn): New inline. (comp-emit-call-cstr): Split logic and call `comp-insert-insn'. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index b6ade0b99d..d7578fdcc0 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2391,16 +2391,21 @@ TARGET-BB-SYM is the symbol name of the target block." (comp-emit-assume 'and target-mvar cstr block-target negated)) finally (cl-return-from in-the-basic-block))))))) +(defsubst comp-insert-insn (insn insn-cell) + "Insert INSN as second insn of INSN-CELL." + (let ((next-cell (cdr insn-cell)) + (new-cell `(,insn))) + (setf (cdr insn-cell) new-cell + (cdr new-cell) next-cell + (comp-func-ssa-status comp-func) 'dirty))) + (defun comp-emit-call-cstr (mvar call-cell cstr) "Emit a constraint CSTR for MVAR after CALL-CELL." - (let* ((next-cell (cdr call-cell)) - (new-mvar (make-comp-mvar :slot (comp-mvar-slot mvar))) + (let* ((new-mvar (make-comp-mvar :slot (comp-mvar-slot mvar))) ;; Have new-mvar as LHS *and* RHS to ensure monotonicity and ;; fwprop convergence!! - (new-cell `((assume ,new-mvar (and ,new-mvar ,mvar ,cstr))))) - (setf (cdr call-cell) new-cell - (cdr new-cell) next-cell - (comp-func-ssa-status comp-func) 'dirty))) + (insn `(assume ,new-mvar (and ,new-mvar ,mvar ,cstr)))) + (comp-insert-insn insn call-cell))) (defun comp-lambda-list-gen (lambda-list) "Return a generator to iterate over LAMBDA-LIST." commit db2a49327a48a375cc2813d5211d762c5dfe55ff Author: Andrea Corallo Date: Wed Dec 30 13:50:23 2020 +0100 * Order function types in aphabetical order * lisp/emacs-lisp/comp.el (comp-known-type-specifiers): Reorder in aphabetical order and comment. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 7e5a9ec951..b6ade0b99d 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -185,133 +185,112 @@ Useful to hook into pass checkers.") ;; FIXME this probably should not be here but... good for now. (defconst comp-known-type-specifiers `( - ;; pure-fns - (cons (function (t t) cons)) - (car (function (list) t)) - (cdr (function (list) t)) - (1+ (function ((or number marker)) number)) - (1- (function ((or number marker)) number)) + ;; Functions we can trust not to be or if redefined should expose + ;; the same type. Vast majority of these is either pure or + ;; pritive, the original list is the union of pure + + ;; side-effect-free-fns + side-effect-and-error-free-fns: + (% (function ((or number marker) (or number marker)) number)) + (* (function (&rest (or number marker)) number)) (+ (function (&rest (or number marker)) number)) (- (function (&rest (or number marker)) number)) - (* (function (&rest (or number marker)) number)) (/ (function ((or number marker) &rest (or number marker)) number)) - (% (function ((or number marker) (or number marker)) number)) - (concat (function (&rest sequence) string)) - (regexp-opt (function (list) string)) - (string-to-char (function (string) fixnum)) - (symbol-name (function (symbol) string)) - (eq (function (t t) boolean)) - (eql (function (t t) boolean)) - (= (function ((or number marker) &rest (or number marker)) boolean)) (/= (function ((or number marker) (or number marker)) boolean)) + (1+ (function ((or number marker)) number)) + (1- (function ((or number marker)) number)) (< (function ((or number marker) &rest (or number marker)) boolean)) (<= (function ((or number marker) &rest (or number marker)) boolean)) - (>= (function ((or number marker) &rest (or number marker)) boolean)) + (= (function ((or number marker) &rest (or number marker)) boolean)) (> (function ((or number marker) &rest (or number marker)) boolean)) - (min (function ((or number marker) &rest (or number marker)) number)) - (max (function ((or number marker) &rest (or number marker)) number)) - (mod (function ((or number marker) (or number marker)) - (or (integer 0 *) (float 0 *)))) + (>= (function ((or number marker) &rest (or number marker)) boolean)) (abs (function (number) number)) - (ash (function (integer integer) integer)) - (sqrt (function (number) float)) - (logand (function (&rest (or integer marker)) integer)) - (logior (function (&rest (or integer marker)) integer)) - (lognot (function (integer) integer)) - (logxor (function (&rest (or integer marker)) integer)) - (logcount (function (integer) integer)) - (copysign (function (float float) float)) - (isnan (function (float) boolean)) - (ldexp (function (number integer) float)) - (float (function (number) float)) - (logb (function (number) integer)) - (floor (function (number &optional number) integer)) - (ceiling (function (number &optional number) integer)) - (round (function (number &optional number) integer)) - (truncate (function (number &optional number) integer)) - (ffloor (function (float) float)) - (fceiling (function (float) float)) - (fround (function (float) float)) - (ftruncate (function (float) float)) - (string= (function ((or string symbol) (or string symbol)) boolean)) - (string-equal (function ((or string symbol) (or string symbol)) boolean)) - (string< (function ((or string symbol) (or string symbol)) boolean)) - (string-lessp (function ((or string symbol) (or string symbol)) boolean)) - (string-search (function (string string &optional integer) integer)) - (string-to-number (function (string &optional integer) number)) - (string-to-syntax (function (string) cons)) - (substring (function ((or string vector) &optional integer integer) - (or string vector))) - (sxhash (function (t) integer)) - (sxhash-equal (function (t) integer)) - (sxhash-eq (function (t) integer)) - (sxhash-eql (function (t) integer)) - (symbol-function (function (symbol) t)) - (symbol-plist (function (symbol) list)) - (symbol-value (function (symbol) t)) - (string-make-unibyte (function (string) string)) - (string-make-multibyte (function (string) string)) - (string-as-multibyte (function (string) string)) - (string-as-unibyte (function (string) string)) - (string-to-multibyte (function (string) string)) - (tan (function (number) float)) - (time-convert (function (t &optional (or boolean integer)) cons)) - (unibyte-char-to-multibyte (function (fixnum) fixnum)) ;; byte is fixnum - (upcase (function ((or fixnum string)) (or fixnum string))) - (user-full-name (function (&optional integer) string)) - (user-login-name (function (&optional integer) (or string null))) - (user-original-login-name (function (&optional integer) (or string null))) - (custom-variable-p (function (symbol) boolean)) - (vconcat (function (&rest sequence) vector)) - ;; TODO all window-* :x - (zerop (function (number) boolean)) - ;; side-effect-free-fns (acos (function (number) float)) (append (function (&rest list) list)) + (aref (function (array fixnum) t)) + (arrayp (function (t) boolean)) + (ash (function (integer integer) integer)) (asin (function (number) float)) + (assq (function (t list) list)) (atan (function (number &optional number) float)) + (atom (function (t) boolean)) + (bignump (function (t) boolean)) + (bobp (function () boolean)) + (bolp (function () boolean)) + (bool-vector-count-consecutive (function (bool-vector bool-vector integer) fixnum)) + (bool-vector-count-population (function (bool-vector) fixnum)) + (bool-vector-not (function (bool-vector &optional bool-vector) bool-vector)) + (bool-vector-p (function (t) boolean)) + (bool-vector-subsetp (function (bool-vector bool-vector) boolean)) (boundp (function (symbol) boolean)) + (buffer-end (function ((or number marker)) integer)) (buffer-file-name (function (&optional buffer) string)) + (buffer-list (function (&optional frame) list)) (buffer-local-variables (function (&optional buffer) list)) (buffer-modified-p (function (&optional buffer) boolean)) + (buffer-size (function (&optional buffer) integer)) + (buffer-string (function () string)) (buffer-substring (function ((or integer marker) (or integer marker)) string)) + (bufferp (function (t) boolean)) (byte-code-function-p (function (t) boolean)) (capitalize (function (or integer string) (or integer string))) + (car (function (list) t)) (car-less-than-car (function (list list) boolean)) + (car-safe (function (t) t)) + (case-table-p (function (t) boolean)) + (cdr (function (list) t)) + (cdr-safe (function (t) t)) + (ceiling (function (number &optional number) integer)) (char-after (function (&optional (or marker integer)) fixnum)) (char-before (function (&optional (or marker integer)) fixnum)) (char-equal (function (integer integer) boolean)) + (char-or-string-p (function (t) boolean)) (char-to-string (function (fixnum) string)) (char-width (function (fixnum) fixnum)) - (compare-strings (function (string (or integer marker null) - (or integer marker null) - string (or integer marker null) - (or integer marker null) - &optional t) - (or (member t) fixnum))) + (characterp (function (t &optional t) boolean)) + (charsetp (function (t) boolean)) + (commandp (function (t &optional t) boolean)) + (compare-strings (function (string (or integer marker null) (or integer marker null) string (or integer marker null) (or integer marker null) &optional t) (or (member t) fixnum))) + (concat (function (&rest sequence) string)) + (cons (function (t t) cons)) + (consp (function (t) boolean)) (coordinates-in-window-p (function (cons window) boolean)) (copy-alist (function (list) list)) - (copy-sequence (function (sequence) sequence)) (copy-marker (function (&optional (or integer marker) boolean) marker)) + (copy-sequence (function (sequence) sequence)) + (copysign (function (float float) float)) (cos (function (number) float)) - (count-lines (function ((or integer marker) (or integer marker) &optional t) - integer)) + (count-lines (function ((or integer marker) (or integer marker) &optional t) integer)) + (current-buffer (function () buffer)) + (current-global-map (function () cons)) + (current-indentation (function () integer)) + (current-local-map (function () cons)) + (current-minor-mode-maps (function () cons)) + (current-time (function () cons)) (current-time-string (function (&optional string boolean) string)) (current-time-zone (function (&optional string boolean) cons)) + (custom-variable-p (function (symbol) boolean)) (decode-char (function (cons t) (or fixnum null))) (decode-time (function (&optional string symbol symbol) cons)) (default-boundp (function (symbol) boolean)) (default-value (function (symbol) t)) - (documentation (function ((or function symbol subr) &optional t) - (or null string))) + (degrees-to-radians (function (number) float)) + (documentation (function ((or function symbol subr) &optional t) (or null string))) (downcase (function ((or fixnum string)) (or fixnum string))) + (elt (function (sequence integer) t)) (encode-char (function (fixnum symbol) (or fixnum null))) - (exp (function (number) float)) - (expt (function (number number) float)) (encode-time (function (cons &rest t) cons)) + (eobp (function () boolean)) + (eolp (function () boolean)) + (eq (function (t t) boolean)) + (eql (function (t t) boolean)) + (equal (function (t t) boolean)) (error-message-string (function (list) string)) + (eventp (function (t) boolean)) + (exp (function (number) float)) + (expt (function (number number) float)) (fboundp (function (symbol) boolean)) + (fceiling (function (float) float)) (featurep (function (symbol &optional symbol) boolean)) + (ffloor (function (float) float)) (file-directory-p (function (string) boolean)) (file-exists-p (function (string) boolean)) (file-locked-p (function (string) boolean)) @@ -320,174 +299,179 @@ Useful to hook into pass checkers.") (file-readable-p (function (string) boolean)) (file-symlink-p (function (string) boolean)) (file-writable-p (function (string) boolean)) + (fixnump (function (t) boolean)) + (float (function (number) float)) (float-time (function (&optional cons) float)) + (floatp (function (t) boolean)) + (floor (function (number &optional number) integer)) + (following-char (function () fixnum)) (format (function (string &rest t) string)) (format-time-string (function (string &optional cons symbol) string)) (frame-first-window (function ((or frame window)) window)) (frame-root-window (function (&optional (or frame window)) window)) (frame-selected-window (function (&optional (or frame window)) window)) (frame-visible-p (function (frame) boolean)) + (framep (function (t) boolean)) + (fround (function (float) float)) + (ftruncate (function (float) float)) (get (function (symbol symbol) t)) - (gethash (function (t hash-table &optional t) t)) (get-buffer (function ((or buffer string)) (or buffer null))) - (get-buffer-window (function (&optional (or buffer string) - (or symbol (integer 0 0))) - (or null window))) - (getenv (function (string &optional frame) (or null string))) + (get-buffer-window (function (&optional (or buffer string) (or symbol (integer 0 0))) (or null window))) (get-file-buffer (function (string) (or null buffer))) + (get-largest-window (function (&optional t t t) window)) + (get-lru-window (function (&optional t t t) window)) + (getenv (function (string &optional frame) (or null string))) + (gethash (function (t hash-table &optional t) t)) (hash-table-count (function (hash-table) integer)) + (hash-table-p (function (t) boolean)) + (identity (function (t) t)) + (ignore (function (&rest t) null)) (int-to-string (function (number) string)) + (integer-or-marker-p (function (t) boolean)) + (integerp (function (t) boolean)) + (interactive-p (function () boolean)) (intern-soft (function (string &optional vector) symbol)) + (invocation-directory (function () string)) + (invocation-name (function () string)) + (isnan (function (float) boolean)) (keymap-parent (function (cons) (or cons null))) + (keymapp (function (t) boolean)) + (keywordp (function (t) boolean)) + (last (function (list &optional integer) list)) + (lax-plist-get (function (list t) t)) + (ldexp (function (number integer) float)) + (length (function (sequence) integer)) (length< (function (sequence fixnum) boolean)) - (length> (function (sequence fixnum) boolean)) (length= (function (sequence fixnum) boolean)) + (length> (function (sequence fixnum) boolean)) (line-beginning-position (function (&optional integer) integer)) (line-end-position (function (&optional integer) integer)) + (list (function (&rest t) list)) + (listp (function (t) boolean)) (local-variable-if-set-p (function (symbol &optional buffer) boolean)) (local-variable-p (function (symbol &optional buffer) boolean)) - (locale-info (function ((member codeset days months paper)) - (or null string))) + (locale-info (function ((member codeset days months paper)) (or null string))) (log (function (number number) float)) (log10 (function (number) float)) + (logand (function (&rest (or integer marker)) integer)) + (logb (function (number) integer)) + (logcount (function (integer) integer)) + (logior (function (&rest (or integer marker)) integer)) + (lognot (function (integer) integer)) + (logxor (function (&rest (or integer marker)) integer)) ;; (lsh (function ((integer ,most-negative-fixnum *) integer) integer)) ? (lsh (function (integer integer) integer)) - (make-byte-code (function ((or fixnum list) string vector integer &optional - string t &rest t) - vector)) + (make-byte-code (function ((or fixnum list) string vector integer &optional string t &rest t) vector)) (make-list (function (integer t) list)) + (make-marker (function () marker)) (make-string (function (integer fixnum &optional t) string)) (make-symbol (function (string) symbol)) - (marker-buffer (function (marker) buffer)) - (minibuffer-selected-window (function () window)) - (minibuffer-window (function (&optional frame) window)) - (multibyte-char-to-unibyte (function (fixnum) fixnum)) - (next-window (function (&optional window t t) window)) - (number-to-string (function (number) string)) - (parse-colon-path (function (string) cons)) - (previous-window (function (&optional window t t) window)) - (prin1-to-string (function (t &optional t) string)) - (propertize (function (string &rest t) string)) - (degrees-to-radians (function (number) float)) - (radians-to-degrees (function (number) float)) - (read-from-string (function (string &ptional integer integer) cons)) - (region-beginning (function () integer)) - (region-end (function () integer)) - (reverse (function (sequence) sequence)) - (sin (function (number) float)) - (string (function (&rest fixnum) strng)) - (get-largest-window (function (&optional t t t) window)) - (get-lru-window (function (&optional t t t) window)) - (one-window-p (function (&optional t t) boolean)) - (regexp-quote (function (string) string)) - (proper-list-p (function (t) integer)) - (nth (function (integer list) t)) - (nthcdr (function (integer list) list)) - (last (function (list &optional integer) list)) - (length (function (sequence) integer)) - (memq (function (t list) list)) - (memql (function (t list) list)) - (member (function (t list) list)) - (assq (function (t list) list)) - (rassq (function (t list) list)) - (rassoc (function (t list) list)) - (plist-get (function (list t) t)) - (lax-plist-get (function (list t) t)) - (plist-member (function (list t) list)) - (aref (function (array fixnum) t)) - (elt (function (sequence integer) t)) - (bool-vector-subsetp (function (bool-vector bool-vector) boolean)) - (bool-vector-not (function (bool-vector &optional bool-vector) bool-vector)) - (bool-vector-count-population (function (bool-vector) fixnum)) - (bool-vector-count-consecutive (function (bool-vector bool-vector integer) - fixnum)) - ;; side-effect-and-error-free-fns - (arrayp (function (t) boolean)) - (atom (function (t) boolean)) - (bignump (function (t) boolean)) - (bobp (function () boolean)) - (bolp (function () boolean)) - (bool-vector-p (function (t) boolean)) - (buffer-end (function ((or number marker)) integer)) - (buffer-list (function (&optional frame) list)) - (buffer-size (function (&optional buffer) integer)) - (buffer-string (function () string)) - (bufferp (function (t) boolean)) - (car-safe (function (t) t)) - (case-table-p (function (t) boolean)) - (cdr-safe (function (t) t)) - (char-or-string-p (function (t) boolean)) - (characterp (function (t &optional t) boolean)) - (charsetp (function (t) boolean)) - (commandp (function (t &optional t) boolean)) - (consp (function (t) boolean)) - (current-buffer (function () buffer)) - (current-global-map (function () cons)) - (current-indentation (function () integer)) - (current-local-map (function () cons)) - (current-minor-mode-maps (function () cons)) - (current-time (function () cons)) - (eobp (function () boolean)) - (eolp (function () boolean)) - (equal (function (t t) boolean)) - (eventp (function (t) boolean)) - (fixnump (function (t) boolean)) - (floatp (function (t) boolean)) - (following-char (function () fixnum)) - (framep (function (t) boolean)) - (hash-table-p (function (t) boolean)) - (identity (function (t) t)) - (ignore (function (&rest t) null)) - (integerp (function (t) boolean)) - (integer-or-marker-p (function (t) boolean)) - (interactive-p (function () boolean)) - (invocation-directory (function () string)) - (invocation-name (function () string)) - (keymapp (function (t) boolean)) - (keywordp (function (t) boolean)) - (list (function (&rest t) list)) - (listp (function (t) boolean)) - (make-marker (function () marker)) (mark (function (&optional t) (or integer null))) (mark-marker (function () marker)) + (marker-buffer (function (marker) buffer)) (markerp (function (t) boolean)) + (max (function ((or number marker) &rest (or number marker)) number)) (max-char (function () fixnum)) + (member (function (t list) list)) (memory-limit (function () integer)) + (memq (function (t list) list)) + (memql (function (t list) list)) + (min (function ((or number marker) &rest (or number marker)) number)) + (minibuffer-selected-window (function () window)) + (minibuffer-window (function (&optional frame) window)) + (mod (function ((or number marker) (or number marker)) (or (integer 0 *) (float 0 *)))) (mouse-movement-p (function (t) boolean)) + (multibyte-char-to-unibyte (function (fixnum) fixnum)) (natnump (function (t) boolean)) + (next-window (function (&optional window t t) window)) (nlistp (function (t) boolean)) (not (function (t) boolean)) + (nth (function (integer list) t)) + (nthcdr (function (integer list) list)) (null (function (t) boolean)) (number-or-marker-p (function (t) boolean)) + (number-to-string (function (number) string)) (numberp (function (t) boolean)) + (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)) (point (function () integer)) (point-marker (function () marker)) - (point-min (function () integer)) (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)) (processp (function (t) boolean)) + (proper-list-p (function (t) integer)) + (propertize (function (string &rest t) string)) + (radians-to-degrees (function (number) float)) + (rassoc (function (t list) list)) + (rassq (function (t list) list)) + (read-from-string (function (string &ptional integer integer) cons)) (recent-keys (function (&optional (or cons null)) vector)) (recursion-depth (function () integer)) + (regexp-opt (function (list) string)) + (regexp-quote (function (string) string)) + (region-beginning (function () integer)) + (region-end (function () integer)) + (reverse (function (sequence) sequence)) + (round (function (number &optional number) integer)) (safe-length (function (t) integer)) (selected-frame (function () frame)) (selected-window (function () window)) (sequencep (function (t) boolean)) + (sin (function (number) float)) + (sqrt (function (number) float)) (standard-case-table (function () char-table)) (standard-syntax-table (function () char-table)) + (string (function (&rest fixnum) strng)) + (string-as-multibyte (function (string) string)) + (string-as-unibyte (function (string) string)) + (string-equal (function ((or string symbol) (or string symbol)) boolean)) + (string-lessp (function ((or string symbol) (or string symbol)) boolean)) + (string-make-multibyte (function (string) string)) + (string-make-unibyte (function (string) string)) + (string-search (function (string string &optional integer) integer)) + (string-to-char (function (string) fixnum)) + (string-to-multibyte (function (string) string)) + (string-to-number (function (string &optional integer) number)) + (string-to-syntax (function (string) cons)) + (string< (function ((or string symbol) (or string symbol)) boolean)) + (string= (function ((or string symbol) (or string symbol)) boolean)) (stringp (function (t) boolean)) (subrp (function (t) boolean)) + (substring (function ((or string vector) &optional integer integer) (or string vector))) + (sxhash (function (t) integer)) + (sxhash-eq (function (t) integer)) + (sxhash-eql (function (t) integer)) + (sxhash-equal (function (t) integer)) + (symbol-function (function (symbol) t)) + (symbol-name (function (symbol) string)) + (symbol-plist (function (symbol) list)) + (symbol-value (function (symbol) t)) (symbolp (function (t) boolean)) (syntax-table (function () char-table)) (syntax-table-p (function (t) boolean)) + (tan (function (number) float)) (this-command-keys (function () string)) (this-command-keys-vector (function () vector)) (this-single-command-keys (function () vector)) (this-single-command-raw-keys (function () vector)) + (time-convert (function (t &optional (or boolean integer)) cons)) + (truncate (function (number &optional number) integer)) (type-of (function (t) symbol)) + (unibyte-char-to-multibyte (function (fixnum) fixnum)) ;; byte is fixnum + (upcase (function ((or fixnum string)) (or fixnum string))) + (user-full-name (function (&optional integer) string)) + (user-login-name (function (&optional integer) (or string null))) + (user-original-login-name (function (&optional integer) (or string null))) (user-real-login-name (function () string)) (user-real-uid (function () integer)) (user-uid (function () integer)) + (vconcat (function (&rest sequence) vector)) (vector (function (&rest t) vector)) (vectorp (function (t) boolean)) (visible-frame-list (function () list)) @@ -496,6 +480,7 @@ Useful to hook into pass checkers.") (window-live-p (function (t) boolean)) (window-valid-p (function (t) boolean)) (windowp (function (t) boolean)) + (zerop (function (number) boolean)) ;; Type hints (comp-hint-fixnum (function (t) fixnum)) (comp-hint-cons (function (t) cons)) commit 0593f478762437e2a8618f3f874a26424e4590b4 Author: Andrea Corallo Date: Tue Dec 29 19:41:28 2020 +0100 * Add more function type specifiers * lisp/emacs-lisp/comp.el (comp-known-type-specifiers): Add more type specifiers. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index bf266256f7..7e5a9ec951 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -184,7 +184,11 @@ Useful to hook into pass checkers.") ;; FIXME this probably should not be here but... good for now. (defconst comp-known-type-specifiers - `((cons (function (t t) cons)) + `( + ;; pure-fns + (cons (function (t t) cons)) + (car (function (list) t)) + (cdr (function (list) t)) (1+ (function ((or number marker)) number)) (1- (function ((or number marker)) number)) (+ (function (&rest (or number marker)) number)) @@ -194,7 +198,7 @@ Useful to hook into pass checkers.") (% (function ((or number marker) (or number marker)) number)) (concat (function (&rest sequence) string)) (regexp-opt (function (list) string)) - (string-to-char (function (string) integer)) + (string-to-char (function (string) fixnum)) (symbol-name (function (symbol) string)) (eq (function (t t) boolean)) (eql (function (t t) boolean)) @@ -234,16 +238,15 @@ Useful to hook into pass checkers.") (string< (function ((or string symbol) (or string symbol)) boolean)) (string-lessp (function ((or string symbol) (or string symbol)) boolean)) (string-search (function (string string &optional integer) integer)) - (string-to-char (function (string) integer)) (string-to-number (function (string &optional integer) number)) (string-to-syntax (function (string) cons)) - (substring (function ((or string vector) &optional integer integer) (or string vector))) + (substring (function ((or string vector) &optional integer integer) + (or string vector))) (sxhash (function (t) integer)) (sxhash-equal (function (t) integer)) (sxhash-eq (function (t) integer)) (sxhash-eql (function (t) integer)) (symbol-function (function (symbol) t)) - (symbol-name (function (symbol) string)) (symbol-plist (function (symbol) list)) (symbol-value (function (symbol) t)) (string-make-unibyte (function (string) string)) @@ -262,6 +265,237 @@ Useful to hook into pass checkers.") (vconcat (function (&rest sequence) vector)) ;; TODO all window-* :x (zerop (function (number) boolean)) + ;; side-effect-free-fns + (acos (function (number) float)) + (append (function (&rest list) list)) + (asin (function (number) float)) + (atan (function (number &optional number) float)) + (boundp (function (symbol) boolean)) + (buffer-file-name (function (&optional buffer) string)) + (buffer-local-variables (function (&optional buffer) list)) + (buffer-modified-p (function (&optional buffer) boolean)) + (buffer-substring (function ((or integer marker) (or integer marker)) string)) + (byte-code-function-p (function (t) boolean)) + (capitalize (function (or integer string) (or integer string))) + (car-less-than-car (function (list list) boolean)) + (char-after (function (&optional (or marker integer)) fixnum)) + (char-before (function (&optional (or marker integer)) fixnum)) + (char-equal (function (integer integer) boolean)) + (char-to-string (function (fixnum) string)) + (char-width (function (fixnum) fixnum)) + (compare-strings (function (string (or integer marker null) + (or integer marker null) + string (or integer marker null) + (or integer marker null) + &optional t) + (or (member t) fixnum))) + (coordinates-in-window-p (function (cons window) boolean)) + (copy-alist (function (list) list)) + (copy-sequence (function (sequence) sequence)) + (copy-marker (function (&optional (or integer marker) boolean) marker)) + (cos (function (number) float)) + (count-lines (function ((or integer marker) (or integer marker) &optional t) + integer)) + (current-time-string (function (&optional string boolean) string)) + (current-time-zone (function (&optional string boolean) cons)) + (decode-char (function (cons t) (or fixnum null))) + (decode-time (function (&optional string symbol symbol) cons)) + (default-boundp (function (symbol) boolean)) + (default-value (function (symbol) t)) + (documentation (function ((or function symbol subr) &optional t) + (or null string))) + (downcase (function ((or fixnum string)) (or fixnum string))) + (encode-char (function (fixnum symbol) (or fixnum null))) + (exp (function (number) float)) + (expt (function (number number) float)) + (encode-time (function (cons &rest t) cons)) + (error-message-string (function (list) string)) + (fboundp (function (symbol) boolean)) + (featurep (function (symbol &optional symbol) boolean)) + (file-directory-p (function (string) boolean)) + (file-exists-p (function (string) boolean)) + (file-locked-p (function (string) boolean)) + (file-name-absolute-p (function (string) boolean)) + (file-newer-than-file-p (function (string string) boolean)) + (file-readable-p (function (string) boolean)) + (file-symlink-p (function (string) boolean)) + (file-writable-p (function (string) boolean)) + (float-time (function (&optional cons) float)) + (format (function (string &rest t) string)) + (format-time-string (function (string &optional cons symbol) string)) + (frame-first-window (function ((or frame window)) window)) + (frame-root-window (function (&optional (or frame window)) window)) + (frame-selected-window (function (&optional (or frame window)) window)) + (frame-visible-p (function (frame) boolean)) + (get (function (symbol symbol) t)) + (gethash (function (t hash-table &optional t) t)) + (get-buffer (function ((or buffer string)) (or buffer null))) + (get-buffer-window (function (&optional (or buffer string) + (or symbol (integer 0 0))) + (or null window))) + (getenv (function (string &optional frame) (or null string))) + (get-file-buffer (function (string) (or null buffer))) + (hash-table-count (function (hash-table) integer)) + (int-to-string (function (number) string)) + (intern-soft (function (string &optional vector) symbol)) + (keymap-parent (function (cons) (or cons null))) + (length< (function (sequence fixnum) boolean)) + (length> (function (sequence fixnum) boolean)) + (length= (function (sequence fixnum) boolean)) + (line-beginning-position (function (&optional integer) integer)) + (line-end-position (function (&optional integer) integer)) + (local-variable-if-set-p (function (symbol &optional buffer) boolean)) + (local-variable-p (function (symbol &optional buffer) boolean)) + (locale-info (function ((member codeset days months paper)) + (or null string))) + (log (function (number number) float)) + (log10 (function (number) float)) + ;; (lsh (function ((integer ,most-negative-fixnum *) integer) integer)) ? + (lsh (function (integer integer) integer)) + (make-byte-code (function ((or fixnum list) string vector integer &optional + string t &rest t) + vector)) + (make-list (function (integer t) list)) + (make-string (function (integer fixnum &optional t) string)) + (make-symbol (function (string) symbol)) + (marker-buffer (function (marker) buffer)) + (minibuffer-selected-window (function () window)) + (minibuffer-window (function (&optional frame) window)) + (multibyte-char-to-unibyte (function (fixnum) fixnum)) + (next-window (function (&optional window t t) window)) + (number-to-string (function (number) string)) + (parse-colon-path (function (string) cons)) + (previous-window (function (&optional window t t) window)) + (prin1-to-string (function (t &optional t) string)) + (propertize (function (string &rest t) string)) + (degrees-to-radians (function (number) float)) + (radians-to-degrees (function (number) float)) + (read-from-string (function (string &ptional integer integer) cons)) + (region-beginning (function () integer)) + (region-end (function () integer)) + (reverse (function (sequence) sequence)) + (sin (function (number) float)) + (string (function (&rest fixnum) strng)) + (get-largest-window (function (&optional t t t) window)) + (get-lru-window (function (&optional t t t) window)) + (one-window-p (function (&optional t t) boolean)) + (regexp-quote (function (string) string)) + (proper-list-p (function (t) integer)) + (nth (function (integer list) t)) + (nthcdr (function (integer list) list)) + (last (function (list &optional integer) list)) + (length (function (sequence) integer)) + (memq (function (t list) list)) + (memql (function (t list) list)) + (member (function (t list) list)) + (assq (function (t list) list)) + (rassq (function (t list) list)) + (rassoc (function (t list) list)) + (plist-get (function (list t) t)) + (lax-plist-get (function (list t) t)) + (plist-member (function (list t) list)) + (aref (function (array fixnum) t)) + (elt (function (sequence integer) t)) + (bool-vector-subsetp (function (bool-vector bool-vector) boolean)) + (bool-vector-not (function (bool-vector &optional bool-vector) bool-vector)) + (bool-vector-count-population (function (bool-vector) fixnum)) + (bool-vector-count-consecutive (function (bool-vector bool-vector integer) + fixnum)) + ;; side-effect-and-error-free-fns + (arrayp (function (t) boolean)) + (atom (function (t) boolean)) + (bignump (function (t) boolean)) + (bobp (function () boolean)) + (bolp (function () boolean)) + (bool-vector-p (function (t) boolean)) + (buffer-end (function ((or number marker)) integer)) + (buffer-list (function (&optional frame) list)) + (buffer-size (function (&optional buffer) integer)) + (buffer-string (function () string)) + (bufferp (function (t) boolean)) + (car-safe (function (t) t)) + (case-table-p (function (t) boolean)) + (cdr-safe (function (t) t)) + (char-or-string-p (function (t) boolean)) + (characterp (function (t &optional t) boolean)) + (charsetp (function (t) boolean)) + (commandp (function (t &optional t) boolean)) + (consp (function (t) boolean)) + (current-buffer (function () buffer)) + (current-global-map (function () cons)) + (current-indentation (function () integer)) + (current-local-map (function () cons)) + (current-minor-mode-maps (function () cons)) + (current-time (function () cons)) + (eobp (function () boolean)) + (eolp (function () boolean)) + (equal (function (t t) boolean)) + (eventp (function (t) boolean)) + (fixnump (function (t) boolean)) + (floatp (function (t) boolean)) + (following-char (function () fixnum)) + (framep (function (t) boolean)) + (hash-table-p (function (t) boolean)) + (identity (function (t) t)) + (ignore (function (&rest t) null)) + (integerp (function (t) boolean)) + (integer-or-marker-p (function (t) boolean)) + (interactive-p (function () boolean)) + (invocation-directory (function () string)) + (invocation-name (function () string)) + (keymapp (function (t) boolean)) + (keywordp (function (t) boolean)) + (list (function (&rest t) list)) + (listp (function (t) boolean)) + (make-marker (function () marker)) + (mark (function (&optional t) (or integer null))) + (mark-marker (function () marker)) + (markerp (function (t) boolean)) + (max-char (function () fixnum)) + (memory-limit (function () integer)) + (mouse-movement-p (function (t) boolean)) + (natnump (function (t) boolean)) + (nlistp (function (t) boolean)) + (not (function (t) boolean)) + (null (function (t) boolean)) + (number-or-marker-p (function (t) boolean)) + (numberp (function (t) boolean)) + (overlayp (function (t) boolean)) + (point (function () integer)) + (point-marker (function () marker)) + (point-min (function () integer)) + (point-max (function () integer)) + (preceding-char (function () fixnum)) + (processp (function (t) boolean)) + (recent-keys (function (&optional (or cons null)) vector)) + (recursion-depth (function () integer)) + (safe-length (function (t) integer)) + (selected-frame (function () frame)) + (selected-window (function () window)) + (sequencep (function (t) boolean)) + (standard-case-table (function () char-table)) + (standard-syntax-table (function () char-table)) + (stringp (function (t) boolean)) + (subrp (function (t) boolean)) + (symbolp (function (t) boolean)) + (syntax-table (function () char-table)) + (syntax-table-p (function (t) boolean)) + (this-command-keys (function () string)) + (this-command-keys-vector (function () vector)) + (this-single-command-keys (function () vector)) + (this-single-command-raw-keys (function () vector)) + (type-of (function (t) symbol)) + (user-real-login-name (function () string)) + (user-real-uid (function () integer)) + (user-uid (function () integer)) + (vector (function (&rest t) vector)) + (vectorp (function (t) boolean)) + (visible-frame-list (function () list)) + (wholenump (function (t) boolean)) + (window-configuration-p (function (t) boolean)) + (window-live-p (function (t) boolean)) + (window-valid-p (function (t) boolean)) + (windowp (function (t) boolean)) ;; Type hints (comp-hint-fixnum (function (t) fixnum)) (comp-hint-cons (function (t) cons)) commit 3f00d666e9674ba18f1ded490a27ac2868a32a88 Author: Andrea Corallo Date: Tue Dec 29 17:39:15 2020 +0100 Fix missing negation handling in a bunch of predicates * lisp/emacs-lisp/comp.el (comp-mvar-fixnum-p) (comp-mvar-symbol-p, comp-mvar-cons-p): Consider neg slot. * test/src/comp-tests.el (comp-test-not-cons): New test. * test/src/comp-test-funcs.el (comp-test-not-cons-f): New function. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index b885ff8841..bf266256f7 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -538,6 +538,8 @@ CFG is mutated by a pass.") (integerp high) (= low high)))))))) +;; FIXME move these into cstr? + (defun comp-mvar-value (mvar) "Return the constant value of MVAR. `comp-mvar-value-vld-p' *must* be satisfied before calling @@ -556,18 +558,20 @@ CFG is mutated by a pass.") (defun comp-mvar-fixnum-p (mvar) "Return t if MVAR is certainly a fixnum." - (when-let (range (comp-mvar-range mvar)) - (let* ((low (caar range)) - (high (cdar (last range)))) - (unless (or (eq low '-) - (< low most-negative-fixnum) - (eq high '+) - (> high most-positive-fixnum)) - t)))) + (when (null (comp-mvar-neg mvar)) + (when-let (range (comp-mvar-range mvar)) + (let* ((low (caar range)) + (high (cdar (last range)))) + (unless (or (eq low '-) + (< low most-negative-fixnum) + (eq high '+) + (> high most-positive-fixnum)) + t))))) (defun comp-mvar-symbol-p (mvar) "Return t if MVAR is certainly a symbol." (and (null (comp-mvar-range mvar)) + (null (comp-mvar-neg mvar)) (or (and (null (comp-mvar-valset mvar)) (equal (comp-mvar-typeset mvar) '(symbol))) (and (or (null (comp-mvar-typeset mvar)) @@ -578,6 +582,7 @@ CFG is mutated by a pass.") "Return t if MVAR is certainly a cons." (and (null (comp-mvar-valset mvar)) (null (comp-mvar-range mvar)) + (null (comp-mvar-neg mvar)) (equal (comp-mvar-typeset mvar) '(cons)))) (defun comp-mvar-type-hint-match-p (mvar type-hint) diff --git a/test/src/comp-test-funcs.el b/test/src/comp-test-funcs.el index 7731e6547b..49e80763be 100644 --- a/test/src/comp-test-funcs.el +++ b/test/src/comp-test-funcs.el @@ -449,6 +449,12 @@ (setq x (1+ x))))) res)) +(defun comp-test-not-cons-f (x) + ;; Reduced from `cl-copy-list'. + (if (consp x) + (print x) + (car x))) + ;;;;;;;;;;;;;;;;;;;; ;; Tromey's tests ;; diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 240af102ec..4546eccb62 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -479,6 +479,9 @@ https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-03/msg00914.html." "Check cond-rw does not break target blocks with multiple predecessor." (should (null (comp-test-cond-rw-1-2-f)))) +(comp-deftest comp-test-not-cons () + (should-not (comp-test-not-cons-f nil))) + ;;;;;;;;;;;;;;;;;;;;; ;; Tromey's tests. ;; commit a3b816ff8ce17ec559043b053e60b631e5dc5eb8 Author: Andrea Corallo Date: Tue Dec 29 14:31:16 2020 +0100 * lisp/emacs-lisp/comp-cstr.el (comp-cstr): Better `comp-value-to-cstr'. diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el index ce70242293..c03056e3af 100644 --- a/lisp/emacs-lisp/comp-cstr.el +++ b/lisp/emacs-lisp/comp-cstr.el @@ -61,7 +61,11 @@ '((- . +)))))) (:constructor comp-value-to-cstr (value &aux - (valset (list value)) + (integer (integerp value)) + (valset (unless integer + (list value))) + (range (when integer + `((,value . ,value)))) (typeset ()))) (:constructor comp-irange-to-cstr (irange &aux @@ -170,9 +174,8 @@ Return them as multiple value." collect cstr into positives finally return (cl-values positives negatives))) -(defvar comp-cstr-one (make-comp-cstr :typeset () - :range '((1 . 1))) - "Represent the integer immediate one (1).") +(defvar comp-cstr-one (comp-value-to-cstr 1) + "Represent the integer immediate one.") (defun comp-pred-to-cstr (predicate) "Given PREDICATE return the correspondig constraint." commit c4efb49a27f05284d28eac7f60b28495c68f63fb Author: Andrea Corallo Date: Tue Dec 29 13:29:02 2020 +0100 Constrain mvars under compare and branch with built-in predicates * lisp/emacs-lisp/comp.el (comp-emit-assume): Update. (comp-known-predicate-p): New function. (comp-add-cond-cstrs): Extend to pattern match predicate calls. * lisp/emacs-lisp/comp-cstr.el (comp-cstr-null-p) (comp-pred-to-cstr): New function. * test/src/comp-tests.el (comp-tests-type-spec-tests): Add a number of tests and fix comments. diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el index 8a8e22e030..ce70242293 100644 --- a/lisp/emacs-lisp/comp-cstr.el +++ b/lisp/emacs-lisp/comp-cstr.el @@ -137,6 +137,13 @@ Integer values are handled in the `range' slot.") (null (valset cstr)) (null (range cstr))))) +(defsubst comp-cstr-null-p (x) + "Return t if CSTR is equivalent to the `null' type specifier, nil otherwise." + (with-comp-cstr-accessors + (and (null (typeset x)) + (null (range x)) + (equal (valset x) '(nil))))) + (defun comp-cstrs-homogeneous (cstrs) "Check if constraints CSTRS are all homogeneously negated or non-negated. Return `pos' if they are all positive, `neg' if they are all @@ -167,6 +174,10 @@ Return them as multiple value." :range '((1 . 1))) "Represent the integer immediate one (1).") +(defun comp-pred-to-cstr (predicate) + "Given PREDICATE return the correspondig constraint." + (comp-type-to-cstr (get predicate 'cl-satisfies-deftype))) + ;;; Value handling. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 35a9e05cfb..b885ff8841 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1895,7 +1895,10 @@ into the C code forwarding the compilation unit." ;; in the CFG to infer information on the tested variables. ;; ;; - Range propagation under test and branch (when the test is an -;; arithmetic comparison.) +;; arithmetic comparison). +;; +;; - Type constraint under test and branch (when the test is a +;; known predicate). ;; ;; - Function calls: function calls to function assumed to be not ;; redefinable can be used to add constrains on the function @@ -1956,15 +1959,22 @@ The assume is emitted at the beginning of the block BB." (cl-assert lhs-slot) (pcase kind ('and - (let ((tmp-mvar (if negated - (make-comp-mvar :slot (comp-mvar-slot rhs)) - rhs))) + (if (comp-mvar-p rhs) + (let ((tmp-mvar (if negated + (make-comp-mvar :slot (comp-mvar-slot rhs)) + rhs))) + (push `(assume ,(make-comp-mvar :slot lhs-slot) + (and ,lhs ,tmp-mvar)) + (comp-block-insns bb)) + (if negated + (push `(assume ,tmp-mvar (not ,rhs)) + (comp-block-insns bb)))) + ;; If is only a constraint we can negate it directly. (push `(assume ,(make-comp-mvar :slot lhs-slot) - (and ,lhs ,tmp-mvar)) - (comp-block-insns bb)) - (if negated - (push `(assume ,tmp-mvar (not ,rhs)) - (comp-block-insns bb))))) + (and ,lhs ,(if negated + (comp-cstr-negation-make rhs) + rhs))) + (comp-block-insns bb)))) ((pred comp-range-cmp-fun-p) (let ((kind (if negated (comp-negate-range-cmp-fun kind) @@ -2078,6 +2088,10 @@ TARGET-BB-SYM is the symbol name of the target block." (comp-emit-assume 'and obj1 obj2 block-target negated)) finally (cl-return-from in-the-basic-block))))))) +(defun comp-known-predicate-p (pred) + (when (symbolp pred) + (get pred 'cl-satisfies-deftype))) + (defun comp-add-cond-cstrs () "`comp-add-cstrs' worker function for each selected function." (cl-loop @@ -2114,6 +2128,43 @@ TARGET-BB-SYM is the symbol name of the target block." (when (comp-mvar-used-p target-mvar2) (comp-emit-assume (comp-reverse-cmp-fun kind) target-mvar2 op1 block-target negated))) + finally (cl-return-from in-the-basic-block))) + (`((set ,(and (pred comp-mvar-p) cmp-res) + (,(pred comp-call-op-p) + ,(and (pred comp-known-predicate-p) fun) + ,op)) + ;; (comment ,_comment-str) + (cond-jump ,cmp-res ,(pred comp-mvar-p) . ,blocks)) + (cl-loop + with target-mvar = (comp-cond-cstrs-target-mvar op (car insns-seq) b) + with cstr = (comp-pred-to-cstr fun) + for branch-target-cell on blocks + for branch-target = (car branch-target-cell) + for negated in '(t nil) + when (comp-mvar-used-p target-mvar) + do + (let ((block-target (comp-add-cond-cstrs-target-block b branch-target))) + (setf (car branch-target-cell) (comp-block-name block-target)) + (comp-emit-assume 'and target-mvar cstr block-target negated)) + finally (cl-return-from in-the-basic-block))) + ;; Match predicate on the negated branch (unless). + (`((set ,(and (pred comp-mvar-p) cmp-res) + (,(pred comp-call-op-p) + ,(and (pred comp-known-predicate-p) fun) + ,op)) + (set ,neg-cmp-res (call eq ,cmp-res ,(pred comp-cstr-null-p))) + (cond-jump ,neg-cmp-res ,(pred comp-mvar-p) . ,blocks)) + (cl-loop + with target-mvar = (comp-cond-cstrs-target-mvar op (car insns-seq) b) + with cstr = (comp-pred-to-cstr fun) + for branch-target-cell on blocks + for branch-target = (car branch-target-cell) + for negated in '(nil t) + when (comp-mvar-used-p target-mvar) + do + (let ((block-target (comp-add-cond-cstrs-target-block b branch-target))) + (setf (car branch-target-cell) (comp-block-name block-target)) + (comp-emit-assume 'and target-mvar cstr block-target negated)) finally (cl-return-from in-the-basic-block))))))) (defun comp-emit-call-cstr (mvar call-cell cstr) diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index c79190e296..240af102ec 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -837,7 +837,6 @@ Return a list of results." y)) (or (integer 1 1) (integer 3 3))) - ;; 6 ((defun comp-tests-ret-type-spec-f (x) (if x @@ -1035,8 +1034,6 @@ Return a list of results." (or null marker number)) ;; 36 - ;; SBCL: (OR (RATIONAL (5)) (SINGLE-FLOAT 5.0) - ;; (DOUBLE-FLOAT 5.0d0) NULL) !? ((defun comp-tests-ret-type-spec-f (x y) (when (and (> x 3) (> y 2)) @@ -1051,15 +1048,14 @@ Return a list of results." (+ x y))) (or null float (integer * 5))) - ;; 38 SBCL gives: (OR (RATIONAL (2) (10)) (SINGLE-FLOAT 2.0 10.0) - ;; (DOUBLE-FLOAT 2.0d0 10.0d0) NULL)!? + ;; 38 ((defun comp-tests-ret-type-spec-f (x y) (when (and (< 1 x 5) (< 1 y 5)) (+ x y))) (or null float (integer 4 8))) - ;; 37 + ;; 39 ;; SBCL gives: (OR REAL NULL) ((defun comp-tests-ret-type-spec-f (x y) (when (and (<= 1 x 10) @@ -1067,7 +1063,7 @@ Return a list of results." (+ x y))) (or null float (integer 3 13))) - ;; 38 + ;; 40 ;; SBCL: (OR REAL NULL) ((defun comp-tests-ret-type-spec-f (x y) (when (and (<= 1 x 10) @@ -1075,42 +1071,42 @@ Return a list of results." (- x y))) (or null float (integer -2 8))) - ;; 39 + ;; 41 ((defun comp-tests-ret-type-spec-f (x y) (when (and (<= 1 x) (<= 2 y 3)) (- x y))) (or null float (integer -2 *))) - ;; 40 + ;; 42 ((defun comp-tests-ret-type-spec-f (x y) (when (and (<= 1 x 10) (<= 2 y)) (- x y))) (or null float (integer * 8))) - ;; 41 + ;; 43 ((defun comp-tests-ret-type-spec-f (x y) (when (and (<= x 10) (<= 2 y)) (- x y))) (or null float (integer * 8))) - ;; 42 + ;; 44 ((defun comp-tests-ret-type-spec-f (x y) (when (and (<= x 10) (<= y 3)) (- x y))) (or null float integer)) - ;; 43 + ;; 45 ((defun comp-tests-ret-type-spec-f (x y) (when (and (<= 2 x) (<= 3 y)) (- x y))) (or null float integer)) - ;; 44 + ;; 46 ;; SBCL: (OR (RATIONAL (6) (30)) (SINGLE-FLOAT 6.0 30.0) ;; (DOUBLE-FLOAT 6.0d0 30.0d0) NULL) ((defun comp-tests-ret-type-spec-f (x y z i j k) @@ -1123,22 +1119,61 @@ Return a list of results." (+ x y z i j k))) (or null float (integer 12 24))) - ;; 45 + ;; 47 ((defun comp-tests-ret-type-spec-f (x) (when (<= 1 x 5) (1+ x))) (or null float (integer 2 6))) - ;;46 + ;;48 ((defun comp-tests-ret-type-spec-f (x) (when (<= 1 x 5) (1- x))) (or null float (integer 0 4))) - ;; 47 + ;; 49 ((defun comp-tests-ret-type-spec-f () (error "foo")) - nil))) + nil) + + ;; 50 + ((defun comp-tests-ret-type-spec-f (x) + (if (stringp x) + x + 'bar)) + (or (member bar) string)) + + ;; 51 + ((defun comp-tests-ret-type-spec-f (x) + (if (stringp x) + 'bar + x)) + (not string)) + + ;; 52 + ((defun comp-tests-ret-type-spec-f (x) + (if (integerp x) + x + 'bar)) + (or (member bar) integer)) + + ;; 53 + ((defun comp-tests-ret-type-spec-f (x) + (when (integerp x) + x)) + (or null integer)) + + ;; 54 + ((defun comp-tests-ret-type-spec-f (x) + (unless (symbolp x) + x)) + (not symbol)) + + ;; 55 + ((defun comp-tests-ret-type-spec-f (x) + (unless (integerp x) + x)) + (not integer)))) (defun comp-tests-define-type-spec-test (number x) `(comp-deftest ,(intern (format "ret-type-spec-%d" number)) () commit e83c6994e1f2553634e0877e86a8ebaa19fbc5d1 Author: Andrea Corallo Date: Tue Dec 29 11:39:26 2020 +0100 * Define `cl-satisfies-deftype' mapping predicate -> type * lisp/emacs-lisp/cl-macs.el (cl-satisfies-deftype): Define symbol property as reverse of `cl-deftype-satisfies'. diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index f4b22ffbea..7dfcc288e6 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -3198,7 +3198,8 @@ Of course, we really can't know that for sure, so it's just a heuristic." ;; FIXME: Do we really want to consider this a type? (integer-or-marker . integer-or-marker-p) )) - (put type 'cl-deftype-satisfies pred)) + (put type 'cl-deftype-satisfies pred) + (put pred 'cl-satisfies-deftype type)) ;;;###autoload (define-inline cl-typep (val type) commit ba41a183dd5123130a0393b84658ec3f2fdd66f4 Author: Andrea Corallo Date: Tue Dec 29 11:39:04 2020 +0100 * lisp/emacs-lisp/comp-cstr.el (comp-cstr): Better `comp-type-to-cstr'. diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el index 57d93912d2..8a8e22e030 100644 --- a/lisp/emacs-lisp/comp-cstr.el +++ b/lisp/emacs-lisp/comp-cstr.el @@ -49,7 +49,16 @@ "Likewise like `cl--all-builtin-types' but with t as common supertype.") (cl-defstruct (comp-cstr (:constructor comp-type-to-cstr - (type &aux (typeset (list type)))) + (type &aux + (null (eq type 'null)) + (integer (eq type 'integer)) + (typeset (if (or null integer) + nil + (list type))) + (valset (when null + '(nil))) + (range (when integer + '((- . +)))))) (:constructor comp-value-to-cstr (value &aux (valset (list value)) commit 2b3c7c751739f48545c3888549ae312ea334951b Author: Andrea Corallo Date: Mon Dec 28 13:41:38 2020 +0100 Store function type and expose it with `subr-type' * src/lisp.h (struct Lisp_Subr): Add 'type' field. (SUBR_TYPE): New inline accessor. * src/pdumper.c (dump_subr): Update for 'type' field. * src/data.c (Fsubr_type): New primitive. (syms_of_data): Update. * src/comp.c (ABI_VERSION): Bump new ABI version. (make_subr): Set type. (Fcomp__register_lambda, Fcomp__register_subr) (Fcomp__late_register_subr): Receive and pass subr type to 'make_subr'. * src/alloc.c (mark_object): Mark subr type. * lisp/emacs-lisp/comp.el (comp-func): Change slot type into mvar. (comp-emit-for-top-level, comp-emit-lambda-for-top-level): Pass type mvar to subr register functions. (comp-compute-function-type): Fix-up subr type mvars. * test/src/comp-tests.el (comp-tests-check-ret-type-spec): Use `subr-type'. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 3b84569c45..35a9e05cfb 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -497,8 +497,8 @@ CFG is mutated by a pass.") :documentation "Optimization level (see `comp-speed').") (pure nil :type boolean :documentation "t if pure nil otherwise.") - (type nil :type list - :documentation "Derived return type.")) + (type nil :type (or null comp-mvar) + :documentation "Mvar holding the derived return type.")) (cl-defstruct (comp-func-l (:include comp-func)) "Lexically-scoped function." @@ -1696,6 +1696,8 @@ the annotation emission." (make-comp-mvar :constant c-name) (car args) (cdr args) + (setf (comp-func-type f) + (make-comp-mvar :constant nil)) (make-comp-mvar :constant (list @@ -1737,6 +1739,8 @@ These are stored in the reloc data array." (make-comp-mvar :constant (comp-func-c-name func)) (car args) (cdr args) + (setf (comp-func-type func) + (make-comp-mvar :constant nil)) (make-comp-mvar :constant (list @@ -3004,7 +3008,8 @@ These are substituted with a normal 'set' op." (defun comp-compute-function-type (_ func) "Compute type specifier for `comp-func' FUNC. Set it into the `type' slot." - (when (comp-func-l-p func) + (when (and (comp-func-l-p func) + (comp-mvar-p (comp-func-type func))) (let* ((comp-func (make-comp-func)) (res-mvar (apply #'comp-cstr-union (make-comp-cstr) @@ -3019,10 +3024,12 @@ Set it into the `type' slot." do (pcase insn (`(return ,mvar) (push mvar res)))) - finally return res)))) - (setf (comp-func-type func) - `(function ,(comp-args-to-lambda-list (comp-func-l-args func)) - ,(comp-cstr-to-type-spec res-mvar)))))) + finally return res))) + (type `(function ,(comp-args-to-lambda-list (comp-func-l-args func)) + ,(comp-cstr-to-type-spec res-mvar)))) + (comp-add-const-to-relocs type) + ;; Fix it up. + (setf (comp-mvar-value (comp-func-type func)) type)))) (defun comp-finalize-container (cont) "Finalize data container CONT." diff --git a/src/alloc.c b/src/alloc.c index 754b8f2aef..bdf721e527 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -6719,6 +6719,7 @@ mark_object (Lisp_Object arg) mark_object (subr->native_intspec); mark_object (subr->native_comp_u[0]); mark_object (subr->lambda_list[0]); + mark_object (subr->type[0]); } break; diff --git a/src/comp.c b/src/comp.c index ee8ae98e2a..04bf9973d2 100644 --- a/src/comp.c +++ b/src/comp.c @@ -411,7 +411,7 @@ load_gccjit_if_necessary (bool mandatory) /* Increase this number to force a new Vcomp_abi_hash to be generated. */ -#define ABI_VERSION "0" +#define ABI_VERSION "1" /* C symbols emitted for the load relocation mechanism. */ #define CURRENT_THREAD_RELOC_SYM "current_thread_reloc" @@ -4886,8 +4886,8 @@ native_function_doc (Lisp_Object function) static Lisp_Object make_subr (Lisp_Object symbol_name, Lisp_Object minarg, Lisp_Object maxarg, - Lisp_Object c_name, Lisp_Object doc_idx, Lisp_Object intspec, - Lisp_Object comp_u) + Lisp_Object c_name, Lisp_Object type, Lisp_Object doc_idx, + Lisp_Object intspec, Lisp_Object comp_u) { struct Lisp_Native_Comp_Unit *cu = XNATIVE_COMP_UNIT (comp_u); dynlib_handle_ptr handle = cu->handle; @@ -4918,6 +4918,7 @@ make_subr (Lisp_Object symbol_name, Lisp_Object minarg, Lisp_Object maxarg, x->s.doc = XFIXNUM (doc_idx); x->s.native_comp_u[0] = comp_u; x->s.native_c_name[0] = xstrdup (SSDATA (c_name)); + x->s.type[0] = type; Lisp_Object tem; XSETSUBR (tem, &x->s); @@ -4925,11 +4926,12 @@ make_subr (Lisp_Object symbol_name, Lisp_Object minarg, Lisp_Object maxarg, } DEFUN ("comp--register-lambda", Fcomp__register_lambda, Scomp__register_lambda, - 6, 6, 0, + 7, 7, 0, doc: /* Register anonymous lambda. This gets called by top_level_run during the load phase. */) (Lisp_Object reloc_idx, Lisp_Object c_name, Lisp_Object minarg, - Lisp_Object maxarg, Lisp_Object rest, Lisp_Object comp_u) + Lisp_Object maxarg, Lisp_Object type, Lisp_Object rest, + Lisp_Object comp_u) { Lisp_Object doc_idx = FIRST (rest); Lisp_Object intspec = SECOND (rest); @@ -4938,7 +4940,7 @@ This gets called by top_level_run during the load phase. */) return Qnil; Lisp_Object tem = - make_subr (c_name, minarg, maxarg, c_name, doc_idx, intspec, comp_u); + make_subr (c_name, minarg, maxarg, c_name, type, doc_idx, intspec, comp_u); /* We must protect it against GC because the function is not reachable through symbols. */ @@ -4954,17 +4956,18 @@ This gets called by top_level_run during the load phase. */) } DEFUN ("comp--register-subr", Fcomp__register_subr, Scomp__register_subr, - 6, 6, 0, + 7, 7, 0, doc: /* Register exported subr. This gets called by top_level_run during the load phase. */) (Lisp_Object name, Lisp_Object c_name, Lisp_Object minarg, - Lisp_Object maxarg, Lisp_Object rest, Lisp_Object comp_u) + Lisp_Object maxarg, Lisp_Object type, Lisp_Object rest, + Lisp_Object comp_u) { Lisp_Object doc_idx = FIRST (rest); Lisp_Object intspec = SECOND (rest); Lisp_Object tem = - make_subr (SYMBOL_NAME (name), minarg, maxarg, c_name, doc_idx, intspec, - comp_u); + make_subr (SYMBOL_NAME (name), minarg, maxarg, c_name, type, doc_idx, + intspec, comp_u); if (AUTOLOADP (XSYMBOL (name)->u.s.function)) /* Remember that the function was already an autoload. */ @@ -4984,11 +4987,12 @@ This gets called by top_level_run during the load phase. */) } DEFUN ("comp--late-register-subr", Fcomp__late_register_subr, - Scomp__late_register_subr, 6, 6, 0, + Scomp__late_register_subr, 7, 7, 0, doc: /* Register exported subr. This gets called by late_top_level_run during the load phase. */) (Lisp_Object name, Lisp_Object c_name, Lisp_Object minarg, - Lisp_Object maxarg, Lisp_Object rest, Lisp_Object comp_u) + Lisp_Object maxarg, Lisp_Object type, Lisp_Object rest, + Lisp_Object comp_u) { if (!NILP (Fequal (Fsymbol_function (name), Fgethash (name, Vcomp_deferred_pending_h, Qnil)))) diff --git a/src/data.c b/src/data.c index 544b20d50c..c5476495bd 100644 --- a/src/data.c +++ b/src/data.c @@ -896,6 +896,19 @@ function or t otherwise. */) : Qt; } +DEFUN ("subr-type", Fsubr_type, + Ssubr_type, 1, 1, 0, + doc: /* Return the type of SUBR. */) + (Lisp_Object subr) +{ + CHECK_SUBR (subr); +#ifdef HAVE_NATIVE_COMP + return SUBR_TYPE (subr); +#else + return Qnil; +#endif +} + #ifdef HAVE_NATIVE_COMP DEFUN ("subr-native-comp-unit", Fsubr_native_comp_unit, @@ -4057,6 +4070,7 @@ syms_of_data (void) defsubr (&Ssubr_name); defsubr (&Ssubr_native_elisp_p); defsubr (&Ssubr_native_lambda_list); + defsubr (&Ssubr_type); #ifdef HAVE_NATIVE_COMP defsubr (&Ssubr_native_comp_unit); defsubr (&Snative_comp_unit_file); diff --git a/src/lisp.h b/src/lisp.h index efbb7a4524..6f00ae8451 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -2071,6 +2071,7 @@ struct Lisp_Subr Lisp_Object native_comp_u[NATIVE_COMP_FLAG]; char *native_c_name[NATIVE_COMP_FLAG]; Lisp_Object lambda_list[NATIVE_COMP_FLAG]; + Lisp_Object type[NATIVE_COMP_FLAG]; } GCALIGNED_STRUCT; union Aligned_Lisp_Subr { @@ -4759,6 +4760,12 @@ SUBR_NATIVE_COMPILED_DYNP (Lisp_Object a) return SUBR_NATIVE_COMPILEDP (a) && !NILP (XSUBR (a)->lambda_list[0]); } +INLINE Lisp_Object +SUBR_TYPE (Lisp_Object a) +{ + return XSUBR (a)->type[0]; +} + INLINE struct Lisp_Native_Comp_Unit * allocate_native_comp_unit (void) { diff --git a/src/pdumper.c b/src/pdumper.c index ae5bbef9b7..a9c43a463d 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -2860,7 +2860,7 @@ dump_bool_vector (struct dump_context *ctx, const struct Lisp_Vector *v) static dump_off dump_subr (struct dump_context *ctx, const struct Lisp_Subr *subr) { -#if CHECK_STRUCTS && !defined (HASH_Lisp_Subr_35CE99B716) +#if CHECK_STRUCTS && !defined (HASH_Lisp_Subr_AA236F7759) # error "Lisp_Subr changed. See CHECK_STRUCTS comment in config.h." #endif struct Lisp_Subr out; @@ -2893,6 +2893,7 @@ dump_subr (struct dump_context *ctx, const struct Lisp_Subr *subr) dump_field_fixup_later (ctx, &out, subr, &subr->native_c_name[0]); dump_field_lv (ctx, &out, subr, &subr->lambda_list[0], WEIGHT_NORMAL); + dump_field_lv (ctx, &out, subr, &subr->type[0], WEIGHT_NORMAL); } dump_off subr_off = dump_object_finish (ctx, &out, sizeof (out)); if (NATIVE_COMP_FLAG diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index d4eb39a736..c79190e296 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -792,18 +792,14 @@ Return a list of results." (should (subr-native-elisp-p (symbol-function #'comp-tests-fw-prop-1-f))) (should (= (comp-tests-fw-prop-1-f) 6)))) -(defun comp-tests-check-ret-type-spec (func-form type-specifier) +(defun comp-tests-check-ret-type-spec (func-form ret-type) (let ((lexical-binding t) - (speed 2) - (comp-post-pass-hooks - `((comp-final - ,(lambda (_) - (let ((f (gethash (comp-c-func-name (cadr func-form) "F" t) - (comp-ctxt-funcs-h comp-ctxt)))) - (should (equal (cl-third (comp-func-type f)) - type-specifier)))))))) + (comp-speed 2) + (f-name (cl-second func-form))) (eval func-form t) - (native-compile (cadr func-form)))) + (native-compile f-name) + (should (equal (cl-third (subr-type (symbol-function f-name))) + ret-type)))) (cl-eval-when (compile eval load) (defconst comp-tests-type-spec-tests commit 5a8622ba2c623c60fab5b2784d5f15eeebcf46f2 Author: Andrea Corallo Date: Mon Dec 28 12:59:12 2020 +0100 Reorder subr register function arguments to make some room * src/comp.c (Fcomp__register_lambda, Fcomp__register_subr) (Fcomp__late_register_subr): Use a rest arg to pass 'doc_idx' and 'intspec' parameters. * lisp/emacs-lisp/comp.el (comp-emit-for-top-level) (comp-emit-lambda-for-top-level): Update. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 2ca7c50045..3b84569c45 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1693,17 +1693,17 @@ the annotation emission." 'comp--late-register-subr 'comp--register-subr) (make-comp-mvar :constant name) + (make-comp-mvar :constant c-name) (car args) (cdr args) - (make-comp-mvar :constant c-name) (make-comp-mvar :constant - (let* ((h (comp-ctxt-function-docs comp-ctxt)) - (i (hash-table-count h))) - (puthash i (comp-func-doc f) h) - i)) - (make-comp-mvar :constant - (comp-func-int-spec f)) + (list + (let* ((h (comp-ctxt-function-docs comp-ctxt)) + (i (hash-table-count h))) + (puthash i (comp-func-doc f) h) + i) + (comp-func-int-spec f))) ;; This is the compilation unit it-self passed as ;; parameter. (make-comp-mvar :slot 0)))))) @@ -1734,15 +1734,17 @@ These are stored in the reloc data array." (puthash (comp-func-byte-func func) (make-comp-mvar :constant nil) (comp-ctxt-lambda-fixups-h comp-ctxt))) + (make-comp-mvar :constant (comp-func-c-name func)) (car args) (cdr args) - (make-comp-mvar :constant (comp-func-c-name func)) (make-comp-mvar - :constant (let* ((h (comp-ctxt-function-docs comp-ctxt)) - (i (hash-table-count h))) - (puthash i (comp-func-doc func) h) - i)) - (make-comp-mvar :constant (comp-func-int-spec func)) + :constant + (list + (let* ((h (comp-ctxt-function-docs comp-ctxt)) + (i (hash-table-count h))) + (puthash i (comp-func-doc func) h) + i) + (comp-func-int-spec func))) ;; This is the compilation unit it-self passed as ;; parameter. (make-comp-mvar :slot 0))))) diff --git a/src/comp.c b/src/comp.c index 52ebf92c50..ee8ae98e2a 100644 --- a/src/comp.c +++ b/src/comp.c @@ -4925,13 +4925,14 @@ make_subr (Lisp_Object symbol_name, Lisp_Object minarg, Lisp_Object maxarg, } DEFUN ("comp--register-lambda", Fcomp__register_lambda, Scomp__register_lambda, - 7, 7, 0, + 6, 6, 0, doc: /* Register anonymous lambda. This gets called by top_level_run during the load phase. */) - (Lisp_Object reloc_idx, Lisp_Object minarg, Lisp_Object maxarg, - Lisp_Object c_name, Lisp_Object doc_idx, Lisp_Object intspec, - Lisp_Object comp_u) + (Lisp_Object reloc_idx, Lisp_Object c_name, Lisp_Object minarg, + Lisp_Object maxarg, Lisp_Object rest, Lisp_Object comp_u) { + Lisp_Object doc_idx = FIRST (rest); + Lisp_Object intspec = SECOND (rest); struct Lisp_Native_Comp_Unit *cu = XNATIVE_COMP_UNIT (comp_u); if (cu->loaded_once) return Qnil; @@ -4953,13 +4954,14 @@ This gets called by top_level_run during the load phase. */) } DEFUN ("comp--register-subr", Fcomp__register_subr, Scomp__register_subr, - 7, 7, 0, + 6, 6, 0, doc: /* Register exported subr. This gets called by top_level_run during the load phase. */) - (Lisp_Object name, Lisp_Object minarg, Lisp_Object maxarg, - Lisp_Object c_name, Lisp_Object doc_idx, Lisp_Object intspec, - Lisp_Object comp_u) + (Lisp_Object name, Lisp_Object c_name, Lisp_Object minarg, + Lisp_Object maxarg, Lisp_Object rest, Lisp_Object comp_u) { + Lisp_Object doc_idx = FIRST (rest); + Lisp_Object intspec = SECOND (rest); Lisp_Object tem = make_subr (SYMBOL_NAME (name), minarg, maxarg, c_name, doc_idx, intspec, comp_u); @@ -4982,16 +4984,15 @@ This gets called by top_level_run during the load phase. */) } DEFUN ("comp--late-register-subr", Fcomp__late_register_subr, - Scomp__late_register_subr, 7, 7, 0, + Scomp__late_register_subr, 6, 6, 0, doc: /* Register exported subr. This gets called by late_top_level_run during the load phase. */) - (Lisp_Object name, Lisp_Object minarg, Lisp_Object maxarg, - Lisp_Object c_name, Lisp_Object doc, Lisp_Object intspec, - Lisp_Object comp_u) + (Lisp_Object name, Lisp_Object c_name, Lisp_Object minarg, + Lisp_Object maxarg, Lisp_Object rest, Lisp_Object comp_u) { if (!NILP (Fequal (Fsymbol_function (name), Fgethash (name, Vcomp_deferred_pending_h, Qnil)))) - Fcomp__register_subr (name, minarg, maxarg, c_name, doc, intspec, comp_u); + Fcomp__register_subr (name, c_name, minarg, maxarg, type, rest, comp_u); Fremhash (name, Vcomp_deferred_pending_h); return Qnil; } commit eafcc8eda0a78e78d1a53b30dafb22786dd60591 Author: Andrea Corallo Date: Mon Dec 28 11:54:34 2020 +0100 Propagate function calls also when hiddend under funcall * lisp/emacs-lisp/comp.el (comp-fwprop-call): Propagate functions also when called under `funcall'. * test/src/comp-tests.el (comp-tests-type-spec-tests): Add a test. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index c6bd040e5f..2ca7c50045 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2642,6 +2642,10 @@ Return non-nil if the function is folded successfully." F is the function being called with arguments ARGS. Fold the call in case." (unless (comp-function-call-maybe-fold insn f args) + (when (and (eq 'funcall f) + (comp-mvar-value-vld-p (car args))) + (setf f (comp-mvar-value (car args)) + args (cdr args))) (when-let ((cstr-f (gethash f comp-known-func-cstr-h))) (let ((cstr (comp-cstr-f-ret cstr-f))) (setf (comp-mvar-range lval) (comp-cstr-range cstr) diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index dbfa3702ff..d4eb39a736 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -1137,7 +1137,12 @@ Return a list of results." ((defun comp-tests-ret-type-spec-f (x) (when (<= 1 x 5) (1- x))) - (or null float (integer 0 4))))) + (or null float (integer 0 4))) + + ;; 47 + ((defun comp-tests-ret-type-spec-f () + (error "foo")) + nil))) (defun comp-tests-define-type-spec-test (number x) `(comp-deftest ,(intern (format "ret-type-spec-%d" number)) () commit e532ec95529224025465421e97243fda7b559d9a Author: Andrea Corallo Date: Mon Dec 28 11:25:39 2020 +0100 Compute function type for native compiled functions * lisp/emacs-lisp/comp.el (comp-func): `type' rename from `ret-type-specifier'. (comp-args-to-lambda-list): New function. (comp-compute-function-type): New function from `comp-ret-type-spec'. (comp-final): Update. * test/src/comp-tests.el (comp-tests-check-ret-type-spec): Update. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index a9caeace65..c6bd040e5f 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -497,8 +497,8 @@ CFG is mutated by a pass.") :documentation "Optimization level (see `comp-speed').") (pure nil :type boolean :documentation "t if pure nil otherwise.") - (ret-type-specifier '(t) :type list - :documentation "Derived return type specifier.")) + (type nil :type list + :documentation "Derived return type.")) (cl-defstruct (comp-func-l (:include comp-func)) "Lexically-scoped function." @@ -2970,26 +2970,53 @@ These are substituted with a normal 'set' op." ;;; Final pass specific code. -(defun comp-ret-type-spec (_ func) +(defun comp-args-to-lambda-list (args) + "Return a lambda list for args." + (cl-loop + with res + repeat (comp-args-base-min args) + do (push t res) + finally + (if (comp-args-p args) + (cl-loop + with n = (- (comp-args-max args) (comp-args-min args)) + initially (unless (zerop n) + (push '&optional res)) + repeat n + do (push t res)) + (cl-loop + with n = (- (comp-nargs-nonrest args) (comp-nargs-min args)) + initially (unless (zerop n) + (push '&optional res)) + repeat n + do (push t res) + finally (when (comp-nargs-rest args) + (push '&rest res) + (push 't res)))) + (cl-return (reverse res)))) + +(defun comp-compute-function-type (_ func) "Compute type specifier for `comp-func' FUNC. -Set it into the `ret-type-specifier' slot." - (let* ((comp-func (make-comp-func)) - (res-mvar (apply #'comp-cstr-union - (make-comp-cstr) - (cl-loop - with res = nil - for bb being the hash-value in (comp-func-blocks - func) - do (cl-loop - for insn in (comp-block-insns bb) - ;; Collect over every exit point the returned - ;; mvars and union results. - do (pcase insn - (`(return ,mvar) - (push mvar res)))) - finally return res)))) - (setf (comp-func-ret-type-specifier func) - (comp-cstr-to-type-spec res-mvar)))) +Set it into the `type' slot." + (when (comp-func-l-p func) + (let* ((comp-func (make-comp-func)) + (res-mvar (apply #'comp-cstr-union + (make-comp-cstr) + (cl-loop + with res = nil + for bb being the hash-value in (comp-func-blocks + func) + do (cl-loop + for insn in (comp-block-insns bb) + ;; Collect over every exit point the returned + ;; mvars and union results. + do (pcase insn + (`(return ,mvar) + (push mvar res)))) + finally return res)))) + (setf (comp-func-type func) + `(function ,(comp-args-to-lambda-list (comp-func-l-args func)) + ,(comp-cstr-to-type-spec res-mvar)))))) (defun comp-finalize-container (cont) "Finalize data container CONT." @@ -3093,7 +3120,7 @@ Prepare every function for final compilation and drive the C back-end." (defun comp-final (_) "Final pass driving the C back-end for code emission." - (maphash #'comp-ret-type-spec (comp-ctxt-funcs-h comp-ctxt)) + (maphash #'comp-compute-function-type (comp-ctxt-funcs-h comp-ctxt)) (unless comp-dry-run ;; Always run the C side of the compilation as a sub-process ;; unless during bootstrap or async compilation (bug#45056). GCC diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index d0e482bb50..dbfa3702ff 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -800,7 +800,7 @@ Return a list of results." ,(lambda (_) (let ((f (gethash (comp-c-func-name (cadr func-form) "F" t) (comp-ctxt-funcs-h comp-ctxt)))) - (should (equal (comp-func-ret-type-specifier f) + (should (equal (cl-third (comp-func-type f)) type-specifier)))))))) (eval func-form t) (native-compile (cadr func-form)))) commit 8a0467e2ef3c29fc0e9aaec7b6436c9a9bb279d6 Author: Andrea Corallo Date: Mon Dec 28 11:22:20 2020 +0100 ; lisp/emacs-lisp/comp.el (comp-emit-narg-prologue): Nit. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 8ed1427a57..a9caeace65 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1633,7 +1633,7 @@ the annotation emission." (comp-emit `(set-args-to-local ,(comp-slot-n i))) (comp-emit '(inc-args)) finally (comp-emit '(jump entry_rest_args))) - (when (not (= minarg nonrest)) + (when (/= minarg nonrest) (cl-loop for i from minarg below nonrest for bb = (intern (format "entry_fallback_%s" i)) for next-bb = (if (= (1+ i) nonrest) commit ccce15299ba3846f5c74335d6d7bc55aac29e007 Author: Andrea Corallo Date: Mon Dec 28 10:48:05 2020 +0100 * Improve some slot type into comp.el * lisp/emacs-lisp/comp.el (comp-args-base, comp-args) (comp-nargs, comp-func): Fix the type of some slots. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 6b06ac5840..8ed1427a57 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -375,18 +375,17 @@ This is typically for top-level forms other than defun.") :documentation "When non-nil support late load.")) (cl-defstruct comp-args-base - (min nil :type number + (min nil :type integer :documentation "Minimum number of arguments allowed.")) (cl-defstruct (comp-args (:include comp-args-base)) - (max nil :type number - :documentation "Maximum number of arguments allowed. -To be used when ncall-conv is nil.")) + (max nil :type integer + :documentation "Maximum number of arguments allowed.")) (cl-defstruct (comp-nargs (:include comp-args-base)) "Describe args when the function signature is of kind: (ptrdiff_t nargs, Lisp_Object *args)." - (nonrest nil :type number + (nonrest nil :type integer :documentation "Number of non rest arguments.") (rest nil :type boolean :documentation "t if rest argument is present.")) @@ -479,7 +478,7 @@ into it.") :documentation "SSA status either: 'nil', 'dirty' or 't'. Once in SSA form this *must* be set to 'dirty' every time the topology of the CFG is mutated by a pass.") - (frame-size nil :type number) + (frame-size nil :type integer) (blocks (make-hash-table :test #'eq) :type hash-table :documentation "Basic block symbol -> basic block.") (lap-block (make-hash-table :test #'equal) :type hash-table commit 42fb6de0b366622cd59006f69fbc13c5cf3a0714 Author: Andrea Corallo Date: Sun Dec 27 21:33:07 2020 +0100 Add 1+ 1- integer range propagation support * lisp/emacs-lisp/comp-cstr.el (comp-cstr-one): New special var. * lisp/emacs-lisp/comp.el (comp-fwprop-call): Propagate integer ranges on +1 -1. * test/src/comp-tests.el (comp-tests-type-spec-tests): Add two tests. diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el index 28cffcf066..57d93912d2 100644 --- a/lisp/emacs-lisp/comp-cstr.el +++ b/lisp/emacs-lisp/comp-cstr.el @@ -154,6 +154,10 @@ Return them as multiple value." collect cstr into positives finally return (cl-values positives negatives))) +(defvar comp-cstr-one (make-comp-cstr :typeset () + :range '((1 . 1))) + "Represent the integer immediate one (1).") + ;;; Value handling. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 336ed39145..6b06ac5840 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2651,7 +2651,9 @@ Fold the call in case." (comp-mvar-neg lval) (comp-cstr-neg cstr)))) (cl-case f (+ (comp-cstr-add lval args)) - (- (comp-cstr-sub lval args))))) + (- (comp-cstr-sub lval args)) + (1+ (comp-cstr-add lval `(,(car args) ,comp-cstr-one))) + (1- (comp-cstr-sub lval `(,(car args) ,comp-cstr-one)))))) (defun comp-fwprop-insn (insn) "Propagate within INSN." diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 154229ec87..d0e482bb50 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -1125,7 +1125,19 @@ Return a list of results." (< 1 j 5) (< 1 k 5)) (+ x y z i j k))) - (or null float (integer 12 24))))) + (or null float (integer 12 24))) + + ;; 45 + ((defun comp-tests-ret-type-spec-f (x) + (when (<= 1 x 5) + (1+ x))) + (or null float (integer 2 6))) + + ;;46 + ((defun comp-tests-ret-type-spec-f (x) + (when (<= 1 x 5) + (1- x))) + (or null float (integer 0 4))))) (defun comp-tests-define-type-spec-test (number x) `(comp-deftest ,(intern (format "ret-type-spec-%d" number)) () commit 7d07a718416d6c24df0719483279c4278dce4acb Author: Andrea Corallo Date: Sun Dec 27 14:07:08 2020 +0100 Add sum/subtraction integer range propagation support * lisp/emacs-lisp/comp-cstr.el (comp-range-+, comp-range--): New functions. (comp-cstr-set-range-for-arithm): New macro. (comp-cstr-add-2, comp-cstr-sub-2, comp-cstr-add, comp-cstr-sub): New function. * lisp/emacs-lisp/comp.el (comp-fwprop-call): Wire-up + - integer range propagation. diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el index d41501e680..28cffcf066 100644 --- a/lisp/emacs-lisp/comp-cstr.el +++ b/lisp/emacs-lisp/comp-cstr.el @@ -280,6 +280,22 @@ Return them as multiple value." x (1- x))) +(defsubst comp-range-+ (x y) + (pcase (cons x y) + ((or '(+ . -) '(- . +)) '??) + ((or `(- . ,_) `(,_ . -)) '-) + ((or `(+ . ,_) `(,_ . +)) '+) + (_ (+ x y)))) + +(defsubst comp-range-- (x y) + (pcase (cons x y) + ((or '(+ . +) '(- . -)) '??) + ('(+ . -) '+) + ('(- . +) '-) + ((or `(+ . ,_) `(,_ . -)) '+) + ((or `(- . ,_) `(,_ . +)) '-) + (_ (- x y)))) + (defsubst comp-range-< (x y) (cond ((eq x '+) nil) @@ -389,6 +405,39 @@ Return them as multiple value." (range dst) (range old-dst) (neg dst) (neg old-dst))))) +(defmacro comp-cstr-set-range-for-arithm (dst src1 src2 &rest range-body) + ;; Prevent some code duplication for `comp-cstr-add-2' + ;; `comp-cstr-sub-2'. + (declare (debug (range-body)) + (indent defun)) + `(with-comp-cstr-accessors + (when-let ((r1 (range ,src1)) + (r2 (range ,src2))) + (let* ((l1 (comp-cstr-smallest-in-range r1)) + (l2 (comp-cstr-smallest-in-range r2)) + (h1 (comp-cstr-greatest-in-range r1)) + (h2 (comp-cstr-greatest-in-range r2))) + (setf (typeset ,dst) (when (cl-some (lambda (x) + (comp-subtype-p 'float x)) + (append (typeset src1) + (typeset src2))) + '(float)) + (range ,dst) ,@range-body))))) + +(defun comp-cstr-add-2 (dst src1 src2) + "Sum SRC1 and SRC2 into DST." + (comp-cstr-set-range-for-arithm dst src1 src2 + `((,(comp-range-+ l1 l2) . ,(comp-range-+ h1 h2))))) + +(defun comp-cstr-sub-2 (dst src1 src2) + "Subtract SRC1 and SRC2 into DST." + (comp-cstr-set-range-for-arithm dst src1 src2 + (let ((l (comp-range-- l1 h2)) + (h (comp-range-- h1 l2))) + (if (or (eq l '??) (eq h '??)) + '((- . +)) + `((,l . ,h)))))) + ;;; Union specific code. @@ -742,6 +791,20 @@ SRC can be either a comp-cstr or an integer." `((- . ,low)))))) (comp-cstr-set-cmp-range dst old-dst ext-range)))) +(defun comp-cstr-add (dst srcs) + "Sum SRCS into DST." + (comp-cstr-add-2 dst (cl-first srcs) (cl-second srcs)) + (cl-loop + for src in (nthcdr 2 srcs) + do (comp-cstr-add-2 dst dst src))) + +(defun comp-cstr-sub (dst srcs) + "Subtract SRCS into DST." + (comp-cstr-sub-2 dst (cl-first srcs) (cl-second srcs)) + (cl-loop + for src in (nthcdr 2 srcs) + do (comp-cstr-sub-2 dst dst src))) + (defun comp-cstr-union-no-range (dst &rest srcs) "Combine SRCS by union set operation setting the result in DST. Do not propagate the range component. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 936e47ff39..336ed39145 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2648,7 +2648,10 @@ Fold the call in case." (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-mvar-neg lval) (comp-cstr-neg cstr)))) + (cl-case f + (+ (comp-cstr-add lval args)) + (- (comp-cstr-sub lval args))))) (defun comp-fwprop-insn (insn) "Propagate within INSN." diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 446c30666f..154229ec87 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -1036,7 +1036,96 @@ Return a list of results." ((defun comp-tests-ret-type-spec-f (x) (when (> x 1.0) x)) - (or null marker number)))) + (or null marker number)) + + ;; 36 + ;; SBCL: (OR (RATIONAL (5)) (SINGLE-FLOAT 5.0) + ;; (DOUBLE-FLOAT 5.0d0) NULL) !? + ((defun comp-tests-ret-type-spec-f (x y) + (when (and (> x 3) + (> y 2)) + (+ x y))) + (or null float (integer 7 *))) + + ;; 37 + ;; SBCL: (OR REAL NULL) + ((defun comp-tests-ret-type-spec-f (x y) + (when (and (<= x 3) + (<= y 2)) + (+ x y))) + (or null float (integer * 5))) + + ;; 38 SBCL gives: (OR (RATIONAL (2) (10)) (SINGLE-FLOAT 2.0 10.0) + ;; (DOUBLE-FLOAT 2.0d0 10.0d0) NULL)!? + ((defun comp-tests-ret-type-spec-f (x y) + (when (and (< 1 x 5) + (< 1 y 5)) + (+ x y))) + (or null float (integer 4 8))) + + ;; 37 + ;; SBCL gives: (OR REAL NULL) + ((defun comp-tests-ret-type-spec-f (x y) + (when (and (<= 1 x 10) + (<= 2 y 3)) + (+ x y))) + (or null float (integer 3 13))) + + ;; 38 + ;; SBCL: (OR REAL NULL) + ((defun comp-tests-ret-type-spec-f (x y) + (when (and (<= 1 x 10) + (<= 2 y 3)) + (- x y))) + (or null float (integer -2 8))) + + ;; 39 + ((defun comp-tests-ret-type-spec-f (x y) + (when (and (<= 1 x) + (<= 2 y 3)) + (- x y))) + (or null float (integer -2 *))) + + ;; 40 + ((defun comp-tests-ret-type-spec-f (x y) + (when (and (<= 1 x 10) + (<= 2 y)) + (- x y))) + (or null float (integer * 8))) + + ;; 41 + ((defun comp-tests-ret-type-spec-f (x y) + (when (and (<= x 10) + (<= 2 y)) + (- x y))) + (or null float (integer * 8))) + + ;; 42 + ((defun comp-tests-ret-type-spec-f (x y) + (when (and (<= x 10) + (<= y 3)) + (- x y))) + (or null float integer)) + + ;; 43 + ((defun comp-tests-ret-type-spec-f (x y) + (when (and (<= 2 x) + (<= 3 y)) + (- x y))) + (or null float integer)) + + ;; 44 + ;; SBCL: (OR (RATIONAL (6) (30)) (SINGLE-FLOAT 6.0 30.0) + ;; (DOUBLE-FLOAT 6.0d0 30.0d0) NULL) + ((defun comp-tests-ret-type-spec-f (x y z i j k) + (when (and (< 1 x 5) + (< 1 y 5) + (< 1 z 5) + (< 1 i 5) + (< 1 j 5) + (< 1 k 5)) + (+ x y z i j k))) + (or null float (integer 12 24))))) (defun comp-tests-define-type-spec-test (number x) `(comp-deftest ,(intern (format "ret-type-spec-%d" number)) () commit 92af4e8fc97a3af043904c32488b84c0e943473d Author: Andrea Corallo Date: Sun Dec 27 15:51:57 2020 +0100 * lisp/emacs-lisp/comp-cstr.el (comp-cstr-set-cmp-range): Improve. diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el index 62e3c47ce3..d41501e680 100644 --- a/lisp/emacs-lisp/comp-cstr.el +++ b/lisp/emacs-lisp/comp-cstr.el @@ -374,7 +374,10 @@ Return them as multiple value." "Support range comparison functions." (with-comp-cstr-accessors (if ext-range - (setf (typeset dst) (and (typeset old-dst) '(float)) + (setf (typeset dst) (when (cl-some (lambda (x) + (comp-subtype-p 'float x)) + (typeset old-dst)) + '(float)) (valset dst) () (range dst) (if (range old-dst) (comp-range-intersection (range old-dst) commit 34e9aae4407aceb54c7b6bc4c9b4e3e10ec62314 Author: Andrea Corallo Date: Sun Dec 27 10:58:29 2020 +0100 * Add comp-cstr-greatest-in-range comp-cstr-smallest-in-range * lisp/emacs-lisp/comp-cstr.el (comp-cstr-smallest-in-range) (comp-cstr-greatest-in-range): New function. (comp-cstr->, comp-cstr->=, comp-cstr-<, comp-cstr-<=): Make use of. diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el index 1927207db6..62e3c47ce3 100644 --- a/lisp/emacs-lisp/comp-cstr.el +++ b/lisp/emacs-lisp/comp-cstr.el @@ -288,6 +288,14 @@ Return them as multiple value." ((eq y '-) nil) (t (< x y)))) +(defsubst comp-cstr-smallest-in-range (range) + "Smallest entry in RANGE." + (caar range)) + +(defsubst comp-cstr-greatest-in-range (range) + "Greater entry in RANGE." + (cdar (last range))) + (defun comp-range-union (&rest ranges) "Combine integer intervals RANGES by union set operation." (cl-loop @@ -687,7 +695,7 @@ SRC can be either a comp-cstr or an integer." (if (integerp src) `((,(1+ src) . +)) (when-let* ((range (range src)) - (low (cdar (last range))) + (low (comp-cstr-greatest-in-range range)) (okay (integerp low))) `((,(1+ low) . +)))))) (comp-cstr-set-cmp-range dst old-dst ext-range)))) @@ -700,7 +708,7 @@ SRC can be either a comp-cstr or an integer." (if (integerp src) `((,src . +)) (when-let* ((range (range src)) - (low (cdar (last range))) + (low (comp-cstr-greatest-in-range range)) (okay (integerp low))) `((,low . +)))))) (comp-cstr-set-cmp-range dst old-dst ext-range)))) @@ -713,7 +721,7 @@ SRC can be either a comp-cstr or an integer." (if (integerp src) `((- . ,(1- src))) (when-let* ((range (range src)) - (low (caar (last range))) + (low (comp-cstr-smallest-in-range range)) (okay (integerp low))) `((- . ,(1- low))))))) (comp-cstr-set-cmp-range dst old-dst ext-range)))) @@ -726,7 +734,7 @@ SRC can be either a comp-cstr or an integer." (if (integerp src) `((- . ,src)) (when-let* ((range (range src)) - (low (caar (last range))) + (low (comp-cstr-smallest-in-range range)) (okay (integerp low))) `((- . ,low)))))) (comp-cstr-set-cmp-range dst old-dst ext-range)))) commit ee53560c8cb1236bb60304157882abe8e7cddaff Author: Andrea Corallo Date: Sun Dec 27 17:50:05 2020 +0100 * Don't require trailing backslashes in `comp-eln-load-path' (bug#45462) * src/comp.c (Fcomp_el_to_eln_filename): Don't require trailing backslashes in comp-eln-load-path. diff --git a/src/comp.c b/src/comp.c index ee3c15a2f6..52ebf92c50 100644 --- a/src/comp.c +++ b/src/comp.c @@ -4085,7 +4085,8 @@ If BASE-DIR is nil use the first entry in `comp-eln-load-path'. */) base_dir = Fexpand_file_name (base_dir, Vinvocation_directory); return Fexpand_file_name (filename, - concat2 (base_dir, Vcomp_native_version_dir)); + concat2 (Ffile_name_as_directory (base_dir), + Vcomp_native_version_dir)); } DEFUN ("comp--install-trampoline", Fcomp__install_trampoline, commit 8fb94630136700aa4e74c7fc212b019d2db380ae Merge: 271fb8a269 df882c9701 Author: Andrea Corallo Date: Sun Dec 27 17:54:57 2020 +0100 Merge remote-tracking branch 'savannah/master' into HEAD commit 271fb8a269aff924070b188f23355d0c368356dd Author: Andrea Corallo Date: Sat Dec 26 20:16:26 2020 +0100 * Fix `byte-compile-file' for native compilation (bug#45442) * lisp/emacs-lisp/bytecomp.el (byte-compile-file): Fix logic for native compilation. diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 620f15c619..9f5d121024 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -2020,16 +2020,16 @@ See also `emacs-lisp-byte-compile-and-load'." (insert "\n") ; aaah, unix. (cond ((null target-file) nil) ;We only wanted the warnings! - ((and (or (file-writable-p target-file) - byte-native-compiling) - ;; We attempt to create a temporary file in the - ;; target directory, so the target directory must be - ;; writable. - (file-writable-p - (file-name-directory - ;; Need to expand in case TARGET-FILE doesn't - ;; include a directory (Bug#45287). - (expand-file-name target-file)))) + ((or byte-native-compiling + (and (file-writable-p target-file) + ;; We attempt to create a temporary file in the + ;; target directory, so the target directory must be + ;; writable. + (file-writable-p + (file-name-directory + ;; Need to expand in case TARGET-FILE doesn't + ;; include a directory (Bug#45287). + (expand-file-name target-file))))) ;; We must disable any code conversion here. (let* ((coding-system-for-write 'no-conversion) ;; Write to a tempfile so that if another Emacs @@ -2037,7 +2037,8 @@ See also `emacs-lisp-byte-compile-and-load'." ;; parallel bootstrap), it does not risk getting a ;; half-finished file. (Bug#4196) (tempfile - (make-temp-file (expand-file-name target-file))) + (make-temp-file (when (file-writable-p target-file) + (expand-file-name target-file)))) (default-modes (default-file-modes)) (temp-modes (logand default-modes #o600)) (desired-modes (logand default-modes #o666)) commit d8939520535224ccee663bba5b3da752f1648009 Author: Andrea Corallo Date: Sat Dec 26 13:09:24 2020 +0100 Fix missing float handling into `comp-cstr-set-cmp-range' * lisp/emacs-lisp/comp-cstr.el (comp-cstr-set-cmp-range): Add float handling. * test/src/comp-tests.el (comp-tests-type-spec-tests): Update results. diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el index 9d0c67177b..1927207db6 100644 --- a/lisp/emacs-lisp/comp-cstr.el +++ b/lisp/emacs-lisp/comp-cstr.el @@ -366,7 +366,7 @@ Return them as multiple value." "Support range comparison functions." (with-comp-cstr-accessors (if ext-range - (setf (typeset dst) () + (setf (typeset dst) (and (typeset old-dst) '(float)) (valset dst) () (range dst) (if (range old-dst) (comp-range-intersection (range old-dst) diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index e1c13598ad..446c30666f 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -953,84 +953,84 @@ Return a list of results." ((defun comp-tests-ret-type-spec-f (x) (when (> x 3) x)) - (or null (integer 4 *))) + (or null float (integer 4 *))) ;; 23 ((defun comp-tests-ret-type-spec-f (x) (when (>= x 3) x)) - (or null (integer 3 *))) + (or null float (integer 3 *))) ;; 24 ((defun comp-tests-ret-type-spec-f (x) (when (< x 3) x)) - (or null (integer * 2))) + (or null float (integer * 2))) ;; 25 ((defun comp-tests-ret-type-spec-f (x) (when (<= x 3) x)) - (or null (integer * 3))) + (or null float (integer * 3))) ;; 26 ((defun comp-tests-ret-type-spec-f (x) (when (> 3 x) x)) - (or null (integer * 2))) + (or null float (integer * 2))) ;; 27 ((defun comp-tests-ret-type-spec-f (x) (when (>= 3 x) x)) - (or null (integer * 3))) + (or null float (integer * 3))) ;; 28 ((defun comp-tests-ret-type-spec-f (x) (when (< 3 x) x)) - (or null (integer 4 *))) + (or null float (integer 4 *))) ;; 29 ((defun comp-tests-ret-type-spec-f (x) (when (<= 3 x) x)) - (or null (integer 3 *))) + (or null float (integer 3 *))) ;; 30 ((defun comp-tests-ret-type-spec-f (x) (let ((y 3)) (when (> x y) x))) - (or null (integer 4 *))) + (or null float (integer 4 *))) ;; 31 ((defun comp-tests-ret-type-spec-f (x) (let ((y 3)) (when (> y x) x))) - (or null (integer * 2))) + (or null float (integer * 2))) ;; 32 ((defun comp-tests-ret-type-spec-f (x) (when (and (> x 3) (< x 10)) x)) - (or null (integer 4 9))) + (or null float (integer 4 9))) ;; 33 ((defun comp-tests-ret-type-spec-f (x) (when (or (> x 3) (< x 10)) x)) - (or null integer)) + (or null float integer)) ;; 34 ((defun comp-tests-ret-type-spec-f (x) (when (or (< x 3) (> x 10)) x)) - (or null (integer * 2) (integer 11 *))) + (or null float (integer * 2) (integer 11 *))) ;; 35 No float range support. ((defun comp-tests-ret-type-spec-f (x) commit fc02c8458d636e682b079a68f2ee7347e0299132 Author: Andrea Corallo Date: Sat Dec 26 12:34:58 2020 +0100 * test/src/comp-tests.el (comp-tests-type-spec-tests): Add two more test. diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 22065f8f6e..e1c13598ad 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -1018,7 +1018,21 @@ Return a list of results." x)) (or null (integer 4 9))) - ;; 33 No float range support. + ;; 33 + ((defun comp-tests-ret-type-spec-f (x) + (when (or (> x 3) + (< x 10)) + x)) + (or null integer)) + + ;; 34 + ((defun comp-tests-ret-type-spec-f (x) + (when (or (< x 3) + (> x 10)) + x)) + (or null (integer * 2) (integer 11 *))) + + ;; 35 No float range support. ((defun comp-tests-ret-type-spec-f (x) (when (> x 1.0) x)) commit fcd8c60182efc8bfe7bad11fb74489fe5df28d6b Author: Andrea Corallo Date: Sat Dec 26 12:23:27 2020 +0100 * Remove unnecessary lhs rename in `comp-ssa-rename-insn' * lisp/emacs-lisp/comp.el (comp-ssa-rename-insn): No point to rename lhs as it's being replaced. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index caea81fccc..936e47ff39 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2474,7 +2474,7 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non-nil." (pcase insn (`(,(pred comp-assign-op-p) ,(pred targetp) . ,_) (let ((mvar (aref frame slot-n))) - (setcdr insn (cl-nsubst-if mvar #'targetp (cdr insn)))) + (setf (cddr insn) (cl-nsubst-if mvar #'targetp (cddr insn)))) (new-lvalue)) (`(fetch-handler . ,_) ;; Clobber all no matter what! commit c5c0c06b1c37dc32b992dc4deddd8ec7bf154def Author: Andrea Corallo Date: Sat Dec 26 12:22:21 2020 +0100 * lisp/emacs-lisp/comp.el (comp-known-type-specifiers): Add two functions. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 7d444af8d9..caea81fccc 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -264,7 +264,10 @@ Useful to hook into pass checkers.") (zerop (function (number) boolean)) ;; Type hints (comp-hint-fixnum (function (t) fixnum)) - (comp-hint-cons (function (t) cons))) + (comp-hint-cons (function (t) cons)) + ;; Non returning functions + (error (function (string &rest t) nil)) + (signal (function (symbol t) nil))) "Alist used for type propagation.") (defconst comp-known-func-cstr-h commit 89d5a3a7603a0b096d02f58ba0a1997ad98c63ae Author: Andrea Corallo Date: Fri Dec 25 10:57:02 2020 +0100 Enable integer range narrowing under compare and branch * lisp/emacs-lisp/comp-cstr.el (comp-cstr-set-cmp-range) (comp-cstr->, comp-cstr->=, comp-cstr-<, comp-cstr-<=): New functions. * lisp/emacs-lisp/comp.el (comp-equality-fun-p) (comp-range-cmp-fun-p): New functions. (comp-collect-rhs): Use `comp-assign-op-p' in place of `comp-set-op-p'. (comp-negate-range-cmp-fun, comp-reverse-cmp-fun): New functions. (comp-emit-assume): Rework to be able to emit also comparision assumption. (comp-add-cond-cstrs-simple): Update for new `comp-emit-assume'. (comp-add-cond-cstrs-simple): Update to emit range assumption. (comp-fwprop-insn): Execute range assumptions. * test/src/comp-tests.el (comp-tests-type-spec-tests): Add tests. diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el index 32989f220a..9d0c67177b 100644 --- a/lisp/emacs-lisp/comp-cstr.el +++ b/lisp/emacs-lisp/comp-cstr.el @@ -362,6 +362,22 @@ Return them as multiple value." (push `(,(1+ last-h) . +) res)) (cl-return (reverse res))))) +(defsubst comp-cstr-set-cmp-range (dst old-dst ext-range) + "Support range comparison functions." + (with-comp-cstr-accessors + (if ext-range + (setf (typeset dst) () + (valset dst) () + (range dst) (if (range old-dst) + (comp-range-intersection (range old-dst) + ext-range) + ext-range) + (neg dst) nil) + (setf (typeset dst) (typeset old-dst) + (valset dst) (valset old-dst) + (range dst) (range old-dst) + (neg dst) (neg old-dst))))) + ;;; Union specific code. @@ -663,6 +679,58 @@ Non memoized version of `comp-cstr-intersection-no-mem'." ;;; Entry points. +(defun comp-cstr-> (dst old-dst src) + "Constraint DST being > than SRC. +SRC can be either a comp-cstr or an integer." + (with-comp-cstr-accessors + (let ((ext-range + (if (integerp src) + `((,(1+ src) . +)) + (when-let* ((range (range src)) + (low (cdar (last range))) + (okay (integerp low))) + `((,(1+ low) . +)))))) + (comp-cstr-set-cmp-range dst old-dst ext-range)))) + +(defun comp-cstr->= (dst old-dst src) + "Constraint DST being >= than SRC. +SRC can be either a comp-cstr or an integer." + (with-comp-cstr-accessors + (let ((ext-range + (if (integerp src) + `((,src . +)) + (when-let* ((range (range src)) + (low (cdar (last range))) + (okay (integerp low))) + `((,low . +)))))) + (comp-cstr-set-cmp-range dst old-dst ext-range)))) + +(defun comp-cstr-< (dst old-dst src) + "Constraint DST being < than SRC. +SRC can be either a comp-cstr or an integer." + (with-comp-cstr-accessors + (let ((ext-range + (if (integerp src) + `((- . ,(1- src))) + (when-let* ((range (range src)) + (low (caar (last range))) + (okay (integerp low))) + `((- . ,(1- low))))))) + (comp-cstr-set-cmp-range dst old-dst ext-range)))) + +(defun comp-cstr-<= (dst old-dst src) + "Constraint DST being > than SRC. +SRC can be either a comp-cstr or an integer." + (with-comp-cstr-accessors + (let ((ext-range + (if (integerp src) + `((- . ,src)) + (when-let* ((range (range src)) + (low (caar (last range))) + (okay (integerp low))) + `((- . ,low)))))) + (comp-cstr-set-cmp-range dst old-dst ext-range)))) + (defun comp-cstr-union-no-range (dst &rest srcs) "Combine SRCS by union set operation setting the result in DST. Do not propagate the range component. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 1804f1f9df..7d444af8d9 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -597,6 +597,14 @@ To be used by all entry points." ((null (native-comp-available-p)) (error "Cannot find libgccjit")))) +(defun comp-equality-fun-p (function) + "Equality functions predicate for FUNCTION." + (when (memq function '(eq eql = equal)) t)) + +(defun comp-range-cmp-fun-p (function) + "Predicate for range comparision functions." + (when (memq function '(> < >= <=)) t)) + (defun comp-set-op-p (op) "Assignment predicate for OP." (when (memq op comp-limple-sets) t)) @@ -1876,7 +1884,10 @@ into the C code forwarding the compilation unit." ;; generated from: ;; ;; - Conditional branches: each branch taken or non taken can be used -;; in the CFG to infer infomations on the tested variables. +;; in the CFG to infer information on the tested variables. +;; +;; - Range propagation under test and branch (when the test is an +;; arithmetic comparison.) ;; ;; - Function calls: function calls to function assumed to be not ;; redefinable can be used to add constrains on the function @@ -1907,25 +1918,58 @@ into the C code forwarding the compilation unit." do (cl-loop for insn in (comp-block-insns b) for (op . args) = insn - if (comp-set-op-p op) + if (comp-assign-op-p op) do (comp-collect-mvars (cdr args)) else do (comp-collect-mvars args)))) -(defun comp-emit-assume (lhs rhs bb negated) - "Emit an assume for mvar LHS being RHS. +(defun comp-negate-range-cmp-fun (function) + "Negate FUNCTION." + (cl-ecase function + (> '<=) + (< '>=) + (>= '<) + (<= '>))) + +(defun comp-reverse-cmp-fun (function) + "Reverse FUNCTION." + (cl-case function + (> '<) + (< '>) + (>= '<=) + (<= '>=) + (t function))) + +(defun comp-emit-assume (kind lhs rhs bb negated) + "Emit an assume of kind KIND for mvar LHS being RHS. When NEGATED is non-nil the assumption is negated. The assume is emitted at the beginning of the block BB." - (let ((lhs-slot (comp-mvar-slot lhs)) - (tmp-mvar (if negated - (make-comp-mvar :slot (comp-mvar-slot rhs)) - rhs))) + (let ((lhs-slot (comp-mvar-slot lhs))) (cl-assert lhs-slot) - (push `(assume ,(make-comp-mvar :slot lhs-slot) (and ,lhs ,tmp-mvar)) - (comp-block-insns bb)) - (if negated - (push `(assume ,tmp-mvar (not ,rhs)) - (comp-block-insns bb))) + (pcase kind + ('and + (let ((tmp-mvar (if negated + (make-comp-mvar :slot (comp-mvar-slot rhs)) + rhs))) + (push `(assume ,(make-comp-mvar :slot lhs-slot) + (and ,lhs ,tmp-mvar)) + (comp-block-insns bb)) + (if negated + (push `(assume ,tmp-mvar (not ,rhs)) + (comp-block-insns bb))))) + ((pred comp-range-cmp-fun-p) + (let ((kind (if negated + (comp-negate-range-cmp-fun kind) + kind))) + (push `(assume ,(make-comp-mvar :slot lhs-slot) + (,kind ,lhs + ,(if-let* ((vld (comp-mvar-value-vld-p rhs)) + (val (comp-mvar-value rhs)) + (ok (integerp val))) + val + (make-comp-mvar :slot (comp-mvar-slot rhs))))) + (comp-block-insns bb)))) + (_ (cl-assert nil))) (setf (comp-func-ssa-status comp-func) 'dirty))) (defun comp-add-new-block-between (bb-symbol bb-a bb-b) @@ -2012,7 +2056,7 @@ TARGET-BB-SYM is the symbol name of the target block." do (let ((block-target (comp-add-cond-cstrs-target-block b branch-target))) (setf (car branch-target-cell) (comp-block-name block-target)) - (comp-emit-assume tmp-mvar obj2 block-target negated)) + (comp-emit-assume 'and tmp-mvar obj2 block-target negated)) finally (cl-return-from in-the-basic-block))) (`((cond-jump ,obj1 ,obj2 . ,blocks)) (cl-loop @@ -2023,7 +2067,7 @@ TARGET-BB-SYM is the symbol name of the target block." do (let ((block-target (comp-add-cond-cstrs-target-block b branch-target))) (setf (car branch-target-cell) (comp-block-name block-target)) - (comp-emit-assume obj1 obj2 block-target negated)) + (comp-emit-assume 'and obj1 obj2 block-target negated)) finally (cl-return-from in-the-basic-block))))))) (defun comp-add-cond-cstrs () @@ -2036,26 +2080,32 @@ TARGET-BB-SYM is the symbol name of the target block." for insns-seq on (comp-block-insns b) do (pcase insns-seq - (`((set ,(and (pred comp-mvar-p) obj1) + (`((set ,(and (pred comp-mvar-p) cmp-res) (,(pred comp-call-op-p) - ,(or 'eq 'eql '= 'equal) ,op1 ,op2)) + ,(and (or (pred comp-equality-fun-p) + (pred comp-range-cmp-fun-p)) + fun) + ,op1 ,op2)) ;; (comment ,_comment-str) - (cond-jump ,obj1 ,(pred comp-mvar-p) . ,blocks)) + (cond-jump ,cmp-res ,(pred comp-mvar-p) . ,blocks)) (cl-loop with target-mvar1 = (comp-cond-cstrs-target-mvar op1 (car insns-seq) b) with target-mvar2 = (comp-cond-cstrs-target-mvar op2 (car insns-seq) b) + with equality = (comp-equality-fun-p fun) for branch-target-cell on blocks for branch-target = (car branch-target-cell) for negated in '(t nil) + for kind = (if equality 'and fun) when (or (comp-mvar-used-p target-mvar1) (comp-mvar-used-p target-mvar2)) do (let ((block-target (comp-add-cond-cstrs-target-block b branch-target))) (setf (car branch-target-cell) (comp-block-name block-target)) (when (comp-mvar-used-p target-mvar1) - (comp-emit-assume target-mvar1 op2 block-target negated)) + (comp-emit-assume kind target-mvar1 op2 block-target negated)) (when (comp-mvar-used-p target-mvar2) - (comp-emit-assume target-mvar2 op1 block-target negated))) + (comp-emit-assume (comp-reverse-cmp-fun kind) + target-mvar2 op1 block-target negated))) finally (cl-return-from in-the-basic-block))))))) (defun comp-emit-call-cstr (mvar call-cell cstr) @@ -2610,13 +2660,21 @@ Fold the call in case." (_ (comp-mvar-propagate lval rval)))) (`(assume ,lval (,kind . ,operands)) - (cl-ecase kind + (cl-case kind (and (apply #'comp-cstr-intersection lval operands)) (not ;; Prevent double negation! (unless (comp-cstr-neg (car operands)) - (comp-cstr-value-negation lval (car operands)))))) + (comp-cstr-value-negation lval (car operands)))) + (> + (comp-cstr-> lval (car operands) (cadr operands))) + (>= + (comp-cstr->= lval (car operands) (cadr operands))) + (< + (comp-cstr-< lval (car operands) (cadr operands))) + (<= + (comp-cstr-<= lval (car operands) (cadr operands))))) (`(setimm ,lval ,v) (setf (comp-mvar-value lval) v)) (`(phi ,lval . ,rest) diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 8f0b3406be..22065f8f6e 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -947,7 +947,82 @@ Return a list of results." ((defun comp-tests-ret-type-spec-f (x) (unless x 'foo)) - (or (member foo) null)))) + (or (member foo) null)) + + ;; 22 + ((defun comp-tests-ret-type-spec-f (x) + (when (> x 3) + x)) + (or null (integer 4 *))) + + ;; 23 + ((defun comp-tests-ret-type-spec-f (x) + (when (>= x 3) + x)) + (or null (integer 3 *))) + + ;; 24 + ((defun comp-tests-ret-type-spec-f (x) + (when (< x 3) + x)) + (or null (integer * 2))) + + ;; 25 + ((defun comp-tests-ret-type-spec-f (x) + (when (<= x 3) + x)) + (or null (integer * 3))) + + ;; 26 + ((defun comp-tests-ret-type-spec-f (x) + (when (> 3 x) + x)) + (or null (integer * 2))) + + ;; 27 + ((defun comp-tests-ret-type-spec-f (x) + (when (>= 3 x) + x)) + (or null (integer * 3))) + + ;; 28 + ((defun comp-tests-ret-type-spec-f (x) + (when (< 3 x) + x)) + (or null (integer 4 *))) + + ;; 29 + ((defun comp-tests-ret-type-spec-f (x) + (when (<= 3 x) + x)) + (or null (integer 3 *))) + + ;; 30 + ((defun comp-tests-ret-type-spec-f (x) + (let ((y 3)) + (when (> x y) + x))) + (or null (integer 4 *))) + + ;; 31 + ((defun comp-tests-ret-type-spec-f (x) + (let ((y 3)) + (when (> y x) + x))) + (or null (integer * 2))) + + ;; 32 + ((defun comp-tests-ret-type-spec-f (x) + (when (and (> x 3) + (< x 10)) + x)) + (or null (integer 4 9))) + + ;; 33 No float range support. + ((defun comp-tests-ret-type-spec-f (x) + (when (> x 1.0) + x)) + (or null marker number)))) (defun comp-tests-define-type-spec-test (number x) `(comp-deftest ,(intern (format "ret-type-spec-%d" number)) () commit bd693ccea7ba4a6aafda103f7a9166f76363c86b Author: Andrea Corallo Date: Fri Dec 25 09:39:22 2020 +0100 * Don't emit byte op-code annotations in LIMPLE to optimize for compile-time Saves 10~15% in bootstrap time. * lisp/emacs-lisp/comp.el (comp-op-case): Don't emit op-code annotaitons. (comp-limplify-lap-inst, comp-add-cond-cstrs-simple) (comp-add-cond-cstrs, comp-tco-func): Update accordingly. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 2f39b1d4cb..1804f1f9df 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1390,9 +1390,9 @@ the annotation emission." if body collect `(',op ;; Log all LAP ops except the TAG one. - ,(unless (eq op 'TAG) - `(comp-emit-annotation - ,(concat "LAP op " op-name))) + ;; ,(unless (eq op 'TAG) + ;; `(comp-emit-annotation + ;; ,(concat "LAP op " op-name))) ;; Emit the stack adjustment if present. ,(when (and sp-delta (not (eq 0 sp-delta))) `(cl-incf (comp-sp) ,sp-delta)) @@ -1602,8 +1602,8 @@ the annotation emission." ;; Assume to follow the emission of a setimm. ;; This is checked into comp-emit-switch. (comp-emit-switch (comp-slot+1) - (cl-second (comp-block-insns - (comp-limplify-curr-block comp-pass))))) + (cl-first (comp-block-insns + (comp-limplify-curr-block comp-pass))))) (byte-constant (comp-emit-setimm arg)) (byte-discardN-preserve-tos @@ -2002,7 +2002,7 @@ TARGET-BB-SYM is the symbol name of the target block." (pcase insn-seq (`((set ,(and (pred comp-mvar-p) tmp-mvar) ,(and (pred comp-mvar-p) obj1)) - (comment ,_comment-str) + ;; (comment ,_comment-str) (cond-jump ,tmp-mvar ,obj2 . ,blocks)) (cl-loop for branch-target-cell on blocks @@ -2039,7 +2039,7 @@ TARGET-BB-SYM is the symbol name of the target block." (`((set ,(and (pred comp-mvar-p) obj1) (,(pred comp-call-op-p) ,(or 'eq 'eql '= 'equal) ,op1 ,op2)) - (comment ,_comment-str) + ;; (comment ,_comment-str) (cond-jump ,obj1 ,(pred comp-mvar-p) . ,blocks)) (cl-loop with target-mvar1 = (comp-cond-cstrs-target-mvar op1 (car insns-seq) b) @@ -2856,7 +2856,7 @@ Return the list of m-var ids nuked." for insns-seq on (comp-block-insns b) do (pcase insns-seq (`((set ,l-val (direct-call ,func . ,args)) - (comment ,_comment) + ;; (comment ,_comment) (return ,ret-val)) (when (and (string= func (comp-func-c-name comp-func)) (eq l-val ret-val)) commit b4ee13c94218062baa4d9d15176eee4aaf582d57 Author: Andrea Corallo Date: Thu Dec 24 13:05:30 2020 +0100 * Memoize `comp-subtype-p' * lisp/emacs-lisp/comp-cstr.el (comp-subtype-p): Memoize. (comp-cstr-ctxt): Add `subtype-p-mem' slot. diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el index 19905950b5..32989f220a 100644 --- a/lisp/emacs-lisp/comp-cstr.el +++ b/lisp/emacs-lisp/comp-cstr.el @@ -86,6 +86,9 @@ Integer values are handled in the `range' slot.") (common-supertype-mem (make-hash-table :test #'equal) :type hash-table :documentation "Serve memoization for `comp-common-supertype'.") + (subtype-p-mem (make-hash-table :test #'equal) :type hash-table + :documentation "Serve memoization for +`comp-subtype-p-mem'.") (union-1-mem-no-range (make-hash-table :test #'equal) :type hash-table :documentation "Serve memoization for `comp-cstr-union-1'.") @@ -215,7 +218,11 @@ Return them as multiple value." (defsubst comp-subtype-p (type1 type2) "Return t if TYPE1 is a subtype of TYPE2 or nil otherwise." - (eq (comp-common-supertype-2 type1 type2) type2)) + (let ((types (cons type1 type2))) + (or (gethash types (comp-cstr-ctxt-subtype-p-mem comp-ctxt)) + (puthash types + (eq (comp-common-supertype-2 type1 type2) type2) + (comp-cstr-ctxt-subtype-p-mem comp-ctxt))))) (defun comp-union-typesets (&rest typesets) "Union types present into TYPESETS." commit 2327a983193bd043714274e78ec597592dceab80 Author: Andrea Corallo Date: Thu Dec 24 09:14:28 2020 +0100 * Constrain only mvars that are actually used * lisp/emacs-lisp/comp.el (comp-mvar-used-p, comp-collect-mvars) (comp-collect-rhs): New functions. (comp-add-cond-cstrs-simple, comp-add-cond-cstrs): Update logic. (comp-add-cstrs): Call `comp-collect-rhs' before doing anything else. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index bbeaef37e3..2f39b1d4cb 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1884,6 +1884,34 @@ into the C code forwarding the compilation unit." ;; afterwards both x and y must satisfy the (or number marker) ;; type specifier. + +(defsubst comp-mvar-used-p (mvar) + "Non-nil when MVAR is used as lhs in the current funciton." + (declare (gv-setter (lambda (val) + `(puthash ,mvar ,val comp-pass)))) + (gethash mvar comp-pass)) + +(defun comp-collect-mvars (form) + "Add rhs m-var present in FORM into `comp-pass'." + (cl-loop for x in form + if (consp x) + do (comp-collect-mvars x) + else + when (comp-mvar-p x) + do (setf (comp-mvar-used-p x) t))) + +(defun comp-collect-rhs () + "Collect all lhs mvars into `comp-pass'." + (cl-loop + for b being each hash-value of (comp-func-blocks comp-func) + do (cl-loop + for insn in (comp-block-insns b) + for (op . args) = insn + if (comp-set-op-p op) + do (comp-collect-mvars (cdr args)) + else + do (comp-collect-mvars args)))) + (defun comp-emit-assume (lhs rhs bb negated) "Emit an assume for mvar LHS being RHS. When NEGATED is non-nil the assumption is negated. @@ -1979,21 +2007,23 @@ TARGET-BB-SYM is the symbol name of the target block." (cl-loop for branch-target-cell on blocks for branch-target = (car branch-target-cell) - for block-target = (comp-add-cond-cstrs-target-block b branch-target) for negated in '(nil t) + when (comp-mvar-used-p tmp-mvar) do - (setf (car branch-target-cell) (comp-block-name block-target)) - (comp-emit-assume tmp-mvar obj2 block-target negated) + (let ((block-target (comp-add-cond-cstrs-target-block b branch-target))) + (setf (car branch-target-cell) (comp-block-name block-target)) + (comp-emit-assume tmp-mvar obj2 block-target negated)) finally (cl-return-from in-the-basic-block))) (`((cond-jump ,obj1 ,obj2 . ,blocks)) (cl-loop for branch-target-cell on blocks for branch-target = (car branch-target-cell) - for block-target = (comp-add-cond-cstrs-target-block b branch-target) for negated in '(nil t) + when (comp-mvar-used-p obj1) do - (setf (car branch-target-cell) (comp-block-name block-target)) - (comp-emit-assume obj1 obj2 block-target negated) + (let ((block-target (comp-add-cond-cstrs-target-block b branch-target))) + (setf (car branch-target-cell) (comp-block-name block-target)) + (comp-emit-assume obj1 obj2 block-target negated)) finally (cl-return-from in-the-basic-block))))))) (defun comp-add-cond-cstrs () @@ -2016,13 +2046,16 @@ TARGET-BB-SYM is the symbol name of the target block." with target-mvar2 = (comp-cond-cstrs-target-mvar op2 (car insns-seq) b) for branch-target-cell on blocks for branch-target = (car branch-target-cell) - for block-target = (comp-add-cond-cstrs-target-block b branch-target) for negated in '(t nil) - do (setf (car branch-target-cell) (comp-block-name block-target)) - when target-mvar1 - do (comp-emit-assume target-mvar1 op2 block-target negated) - when target-mvar2 - do (comp-emit-assume target-mvar2 op1 block-target negated) + when (or (comp-mvar-used-p target-mvar1) + (comp-mvar-used-p target-mvar2)) + do + (let ((block-target (comp-add-cond-cstrs-target-block b branch-target))) + (setf (car branch-target-cell) (comp-block-name block-target)) + (when (comp-mvar-used-p target-mvar1) + (comp-emit-assume target-mvar1 op2 block-target negated)) + (when (comp-mvar-used-p target-mvar2) + (comp-emit-assume target-mvar2 op1 block-target negated))) finally (cl-return-from in-the-basic-block))))))) (defun comp-emit-call-cstr (mvar call-cell cstr) @@ -2093,8 +2126,10 @@ blocks." ;; variables. (comp-func-l-p f) (not (comp-func-has-non-local f))) - (let ((comp-func f)) - (comp-add-cond-cstrs-simple) + (let ((comp-func f) + (comp-pass (make-hash-table :test #'eq))) + (comp-collect-rhs) + (comp-add-cond-cstrs-simple) (comp-add-cond-cstrs) (comp-add-call-cstr) (comp-log-func comp-func 3)))) commit 2a6c6bf3242847de5d6a25acbfa2a946617df291 Author: Andrea Corallo Date: Thu Dec 24 08:52:56 2020 +0100 * Use `comp-assign-op-p' into dead code elimination pass * lisp/emacs-lisp/comp.el (comp-dead-assignments-func): Use `comp-assign-op-p' in place of `comp-set-op-p'. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index f73bd4b11e..bbeaef37e3 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2761,7 +2761,7 @@ Return the list of m-var ids nuked." do (cl-loop for insn in (comp-block-insns b) for (op arg0 . rest) = insn - if (comp-set-op-p op) + if (comp-assign-op-p op) do (push (comp-mvar-id arg0) l-vals) (setf r-vals (nconc (comp-collect-mvar-ids rest) r-vals)) else @@ -2779,7 +2779,7 @@ Return the list of m-var ids nuked." for b being each hash-value of (comp-func-blocks comp-func) do (comp-loop-insn-in-block b (cl-destructuring-bind (op &optional arg0 arg1 &rest rest) insn - (when (and (comp-set-op-p op) + (when (and (comp-assign-op-p op) (memq (comp-mvar-id arg0) nuke-list)) (setf insn (if (comp-limple-insn-call-p arg1) commit 96d4c70412ee1f3f0f797d27cd7b8bc5532ba692 Author: Andrea Corallo Date: Tue Dec 22 22:53:05 2020 +0100 * Fix logic for constraining block with multiple predecessors * lisp/emacs-lisp/comp.el (comp-limple-lock-keywords) (comp-add-cond-cstrs-target-block): Logic update. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 297dabbb5d..f73bd4b11e 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -662,7 +662,8 @@ Assume allocation class 'd-default as default." (1 font-lock-variable-name-face)) (,(rx (group-n 1 (or "entry" (seq (or "entry_" "entry_fallback_" "bb_") - (1+ num) (? (or "_latch" "_cstrs")))))) + (1+ num) (? (or "_latch" + (seq "_cstrs_" (1+ num)))))))) (1 font-lock-constant-face)) (,(rx-to-string `(seq "(" (group-n 1 (or ,@(mapcar #'symbol-name comp-limple-ops))))) @@ -1943,15 +1944,23 @@ Keep on searching till EXIT-INSN is encountered." "Return the appropriate basic block to add constraint assumptions into. CURR-BB is the current basic block. TARGET-BB-SYM is the symbol name of the target block." - (let ((target-bb (gethash target-bb-sym - (comp-func-blocks comp-func)))) - (if (= (length (comp-block-in-edges target-bb)) 1) + (let* ((target-bb (gethash target-bb-sym + (comp-func-blocks comp-func))) + (target-bb-in-edges (comp-block-in-edges target-bb))) + (cl-assert target-bb-in-edges) + (if (= (length target-bb-in-edges) 1) ;; If block has only one predecessor is already suitable for ;; adding constraint assumptions. target-bb - (comp-add-new-block-between (intern (concat (symbol-name target-bb-sym) - "_cstrs")) - curr-bb target-bb)))) + (cl-loop + ;; Search for the first suitable basic block name. + for i from 0 + for new-name = (intern (format "%s_cstrs_%d" (symbol-name target-bb-sym) + i)) + until (null (gethash new-name (comp-func-blocks comp-func))) + finally + ;; Add it. + (cl-return (comp-add-new-block-between new-name curr-bb target-bb)))))) (defun comp-add-cond-cstrs-simple () "`comp-add-cstrs' worker function for each selected function." commit 672988e961744750d3ea40904807355336116c3f Author: Andrea Corallo Date: Tue Dec 22 20:39:24 2020 +0100 Symplify (not t) => nil and (not nil) => t * lisp/emacs-lisp/comp-cstr.el (comp-cstr-negation): Symplify (not t) => nil and (not nil) => t. * test/lisp/emacs-lisp/comp-cstr-tests.el (comp-cstr-typespec-tests-alist): Add two tests. diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el index 8b5639c8a4..19905950b5 100644 --- a/lisp/emacs-lisp/comp-cstr.el +++ b/lisp/emacs-lisp/comp-cstr.el @@ -695,10 +695,27 @@ DST is returned." "Negate SRC setting the result in DST. DST is returned." (with-comp-cstr-accessors - (setf (typeset dst) (typeset src) - (valset dst) (valset src) - (range dst) (range src) - (neg dst) (not (neg src))) + (cond + ((and (null (valset src)) + (null (range src)) + (null (neg src)) + (equal (typeset src) '(t))) + (setf (typeset dst) () + (valset dst) () + (range dst) nil + (neg dst) nil)) + ((and (null (valset src)) + (null (range src)) + (null (neg src)) + (null (typeset src))) + (setf (typeset dst) '(t) + (valset dst) () + (range dst) nil + (neg dst) nil)) + (t (setf (typeset dst) (typeset src) + (valset dst) (valset src) + (range dst) (range src) + (neg dst) (not (neg src))))) dst)) (defun comp-cstr-value-negation (dst src) diff --git a/test/lisp/emacs-lisp/comp-cstr-tests.el b/test/lisp/emacs-lisp/comp-cstr-tests.el index 834f4401d9..1e1376b363 100644 --- a/test/lisp/emacs-lisp/comp-cstr-tests.el +++ b/test/lisp/emacs-lisp/comp-cstr-tests.el @@ -203,7 +203,11 @@ ;; 81 ((and t (not t)) . nil) ;; 82 - ((or (integer 1 1) (not (integer 1 1))) . t)) + ((or (integer 1 1) (not (integer 1 1))) . t) + ;; 83 + ((not t) . nil) + ;; 84 + ((not nil) . t)) "Alist type specifier -> expected type specifier.")) (defmacro comp-cstr-synthesize-tests () commit 538f59806c1994df7d77716f896db5602f59dc02 Author: Andrea Corallo Date: Tue Dec 22 15:00:44 2020 +0100 Extend cstrs pass to match `unless' like code * lisp/emacs-lisp/comp.el (comp-emit-assume): Add assertion. (comp-add-new-block-between): Fix two typos. (comp-add-cond-cstrs-target-block): Fix typo. (comp-add-cond-cstrs-simple): Logic update. * test/src/comp-tests.el (comp-tests-type-spec-tests): Add a test. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index ad09210d8d..297dabbb5d 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1891,6 +1891,7 @@ The assume is emitted at the beginning of the block BB." (tmp-mvar (if negated (make-comp-mvar :slot (comp-mvar-slot rhs)) rhs))) + (cl-assert lhs-slot) (push `(assume ,(make-comp-mvar :slot lhs-slot) (and ,lhs ,tmp-mvar)) (comp-block-insns bb)) (if negated @@ -1898,7 +1899,7 @@ The assume is emitted at the beginning of the block BB." (comp-block-insns bb))) (setf (comp-func-ssa-status comp-func) 'dirty))) -(defun comp-add-new-block-beetween (bb-symbol bb-a bb-b) +(defun comp-add-new-block-between (bb-symbol bb-a bb-b) "Create a new basic-block named BB-SYMBOL and add it between BB-A and BB-B." (cl-loop with new-bb = (make-comp-block-cstr :name bb-symbol @@ -1913,8 +1914,8 @@ The assume is emitted at the beginning of the block BB." (comp-block-out-edges bb-a) (delq ed (comp-block-out-edges bb-a))) (push ed (comp-block-out-edges new-bb)) ;; Connect `bb-a' `new-bb' with `new-edge'. - (push (comp-block-out-edges bb-a) new-edge) - (push (comp-block-in-edges new-bb) new-edge) + (push new-edge (comp-block-out-edges bb-a)) + (push new-edge (comp-block-in-edges new-bb)) (setf (comp-func-ssa-status comp-func) 'dirty) ;; Add `new-edge' to the current function and return it. (cl-return (puthash bb-symbol new-bb (comp-func-blocks comp-func))) @@ -1948,9 +1949,9 @@ TARGET-BB-SYM is the symbol name of the target block." ;; If block has only one predecessor is already suitable for ;; adding constraint assumptions. target-bb - (comp-add-new-block-beetween (intern (concat (symbol-name target-bb-sym) - "_cstrs")) - curr-bb target-bb)))) + (comp-add-new-block-between (intern (concat (symbol-name target-bb-sym) + "_cstrs")) + curr-bb target-bb)))) (defun comp-add-cond-cstrs-simple () "`comp-add-cstrs' worker function for each selected function." @@ -1974,6 +1975,16 @@ TARGET-BB-SYM is the symbol name of the target block." do (setf (car branch-target-cell) (comp-block-name block-target)) (comp-emit-assume tmp-mvar obj2 block-target negated) + finally (cl-return-from in-the-basic-block))) + (`((cond-jump ,obj1 ,obj2 . ,blocks)) + (cl-loop + for branch-target-cell on blocks + for branch-target = (car branch-target-cell) + for block-target = (comp-add-cond-cstrs-target-block b branch-target) + for negated in '(nil t) + do + (setf (car branch-target-cell) (comp-block-name block-target)) + (comp-emit-assume obj1 obj2 block-target negated) finally (cl-return-from in-the-basic-block))))))) (defun comp-add-cond-cstrs () diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 039e066537..8f0b3406be 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -941,6 +941,12 @@ Return a list of results." ((defun comp-tests-ret-type-spec-f (x) (when x 'foo)) + (or (member foo) null)) + + ;; 21 + ((defun comp-tests-ret-type-spec-f (x) + (unless x + 'foo)) (or (member foo) null)))) (defun comp-tests-define-type-spec-test (number x) commit 715cac119a02adb489cfda4b8f310cff87c55a2c Author: Andrea Corallo Date: Tue Dec 22 13:04:02 2020 +0100 * lisp/emacs-lisp/comp.el (comp-limplify-lap-inst): Opencode byte-not. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index eef63b52c4..ad09210d8d 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1446,7 +1446,9 @@ the annotation emission." (byte-listp auto) (byte-eq auto) (byte-memq auto) - (byte-not null) + (byte-not + (comp-emit-set-call (comp-call 'eq (comp-slot-n (comp-sp)) + (make-comp-mvar :constant nil)))) (byte-car auto) (byte-cdr auto) (byte-cons auto) commit c07c9f6bf81d2355672839e7423a9f2a5f00e4fb Author: Andrea Corallo Date: Tue Dec 22 10:29:48 2020 +0100 Extend cstrs pass to match `when' like code * lisp/emacs-lisp/comp.el (comp-emit-assume): Better parameter names. (comp-add-cond-cstrs-simple): New function. (comp-add-cond-cstrs): Rename assume-target -> block-target. (comp-add-cstrs): Call `comp-add-cond-cstrs-simple'. * test/src/comp-tests.el (comp-tests-type-spec-tests): Add test. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 599c8c7500..eef63b52c4 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1881,15 +1881,15 @@ into the C code forwarding the compilation unit." ;; afterwards both x and y must satisfy the (or number marker) ;; type specifier. -(defun comp-emit-assume (target rhs bb negated) - "Emit an assume for mvar TARGET being RHS. +(defun comp-emit-assume (lhs rhs bb negated) + "Emit an assume for mvar LHS being RHS. When NEGATED is non-nil the assumption is negated. The assume is emitted at the beginning of the block BB." - (let ((target-slot (comp-mvar-slot target)) + (let ((lhs-slot (comp-mvar-slot lhs)) (tmp-mvar (if negated (make-comp-mvar :slot (comp-mvar-slot rhs)) rhs))) - (push `(assume ,(make-comp-mvar :slot target-slot) (and ,target ,tmp-mvar)) + (push `(assume ,(make-comp-mvar :slot lhs-slot) (and ,lhs ,tmp-mvar)) (comp-block-insns bb)) (if negated (push `(assume ,tmp-mvar (not ,rhs)) @@ -1950,6 +1950,30 @@ TARGET-BB-SYM is the symbol name of the target block." "_cstrs")) curr-bb target-bb)))) +(defun comp-add-cond-cstrs-simple () + "`comp-add-cstrs' worker function for each selected function." + (cl-loop + for b being each hash-value of (comp-func-blocks comp-func) + do + (cl-loop + named in-the-basic-block + for insn-seq on (comp-block-insns b) + do + (pcase insn-seq + (`((set ,(and (pred comp-mvar-p) tmp-mvar) + ,(and (pred comp-mvar-p) obj1)) + (comment ,_comment-str) + (cond-jump ,tmp-mvar ,obj2 . ,blocks)) + (cl-loop + for branch-target-cell on blocks + for branch-target = (car branch-target-cell) + for block-target = (comp-add-cond-cstrs-target-block b branch-target) + for negated in '(nil t) + do + (setf (car branch-target-cell) (comp-block-name block-target)) + (comp-emit-assume tmp-mvar obj2 block-target negated) + finally (cl-return-from in-the-basic-block))))))) + (defun comp-add-cond-cstrs () "`comp-add-cstrs' worker function for each selected function." (cl-loop @@ -1960,23 +1984,23 @@ TARGET-BB-SYM is the symbol name of the target block." for insns-seq on (comp-block-insns b) do (pcase insns-seq - (`((set ,(and (pred comp-mvar-p) cond) + (`((set ,(and (pred comp-mvar-p) obj1) (,(pred comp-call-op-p) ,(or 'eq 'eql '= 'equal) ,op1 ,op2)) (comment ,_comment-str) - (cond-jump ,cond ,(pred comp-mvar-p) . ,blocks)) + (cond-jump ,obj1 ,(pred comp-mvar-p) . ,blocks)) (cl-loop with target-mvar1 = (comp-cond-cstrs-target-mvar op1 (car insns-seq) b) with target-mvar2 = (comp-cond-cstrs-target-mvar op2 (car insns-seq) b) for branch-target-cell on blocks for branch-target = (car branch-target-cell) - for assume-target = (comp-add-cond-cstrs-target-block b branch-target) + for block-target = (comp-add-cond-cstrs-target-block b branch-target) for negated in '(t nil) - do (setf (car branch-target-cell) (comp-block-name assume-target)) + do (setf (car branch-target-cell) (comp-block-name block-target)) when target-mvar1 - do (comp-emit-assume target-mvar1 op2 assume-target negated) + do (comp-emit-assume target-mvar1 op2 block-target negated) when target-mvar2 - do (comp-emit-assume target-mvar2 op1 assume-target negated) + do (comp-emit-assume target-mvar2 op1 block-target negated) finally (cl-return-from in-the-basic-block))))))) (defun comp-emit-call-cstr (mvar call-cell cstr) @@ -2048,6 +2072,7 @@ blocks." (comp-func-l-p f) (not (comp-func-has-non-local f))) (let ((comp-func f)) + (comp-add-cond-cstrs-simple) (comp-add-cond-cstrs) (comp-add-call-cstr) (comp-log-func comp-func 3)))) diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index e0d4bf8df5..039e066537 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -935,7 +935,13 @@ Return a list of results." ;; 19 ((defun comp-tests-ret-type-spec-f (x y) (eq x y)) - boolean))) + boolean) + + ;; 20 + ((defun comp-tests-ret-type-spec-f (x) + (when x + 'foo)) + (or (member foo) null)))) (defun comp-tests-define-type-spec-test (number x) `(comp-deftest ,(intern (format "ret-type-spec-%d" number)) () commit 4deeb2f2eec340f8f2ef6f0d474503ea9b30ed43 Author: Andrea Corallo Date: Tue Dec 22 09:57:51 2020 +0100 Invert basic block argument order in LIMPLE cond-jump * lisp/emacs-lisp/comp.el (comp-emit-cond-jump) (comp-emit-switch, comp-emit-narg-prologue, comp-add-cond-cstrs): Invert basic block argument order in LIMPLE cond-jump. * src/comp.c (emit_limple_insn): Likewise. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 6ed50dc012..599c8c7500 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1229,8 +1229,8 @@ Return value is the fall through block name." (when label-sp (cl-assert (= (1- label-sp) (+ target-offset (comp-sp))))) (comp-emit (if negated - (list 'cond-jump a b eff-target-name bb) - (list 'cond-jump a b bb eff-target-name))) + (list 'cond-jump a b bb eff-target-name) + (list 'cond-jump a b eff-target-name bb))) (comp-mark-curr-bb-closed) bb))) @@ -1321,7 +1321,7 @@ Return value is the fall through block name." (comp-new-block-sym))) for ff-bb-name = (comp-block-name ff-bb) if (eq test-func 'eq) - do (comp-emit (list 'cond-jump var m-test ff-bb-name target-name)) + do (comp-emit (list 'cond-jump var m-test target-name ff-bb-name)) else ;; Store the result of the comparison into the scratch slot before ;; emitting the conditional jump. @@ -1330,7 +1330,7 @@ Return value is the fall through block name." (comp-emit (list 'cond-jump (make-comp-mvar :slot 'scratch) (make-comp-mvar :constant nil) - target-name ff-bb-name)) + ff-bb-name target-name)) unless last ;; All fall through are artificially created here except the last one. do (puthash ff-bb-name ff-bb (comp-func-blocks comp-func)) @@ -1615,7 +1615,7 @@ the annotation emission." (cl-loop for i from minarg below nonrest for bb = (intern (format "entry_%s" i)) for fallback = (intern (format "entry_fallback_%s" i)) - do (comp-emit `(cond-jump-narg-leq ,i ,bb ,fallback)) + do (comp-emit `(cond-jump-narg-leq ,i ,fallback ,bb)) (comp-make-curr-block bb (comp-sp)) (comp-emit `(set-args-to-local ,(comp-slot-n i))) (comp-emit '(inc-args)) @@ -1971,7 +1971,7 @@ TARGET-BB-SYM is the symbol name of the target block." for branch-target-cell on blocks for branch-target = (car branch-target-cell) for assume-target = (comp-add-cond-cstrs-target-block b branch-target) - for negated in '(nil t) + for negated in '(t nil) do (setf (car branch-target-cell) (comp-block-name assume-target)) when target-mvar1 do (comp-emit-assume target-mvar1 op2 assume-target negated) diff --git a/src/comp.c b/src/comp.c index 166c75bea0..ee3c15a2f6 100644 --- a/src/comp.c +++ b/src/comp.c @@ -2038,7 +2038,7 @@ emit_limple_insn (Lisp_Object insn) gcc_jit_block *target1 = retrive_block (arg[2]); gcc_jit_block *target2 = retrive_block (arg[3]); - emit_cond_jump (emit_EQ (a, b), target2, target1); + emit_cond_jump (emit_EQ (a, b), target1, target2); } else if (EQ (op, Qcond_jump_narg_leq)) { @@ -2060,7 +2060,7 @@ emit_limple_insn (Lisp_Object insn) GCC_JIT_COMPARISON_LE, gcc_jit_lvalue_as_rvalue (nargs), n); - emit_cond_jump (test, target2, target1); + emit_cond_jump (test, target1, target2); } else if (EQ (op, Qphi) || EQ (op, Qassume)) { commit b99a4744822a11e4af098b63db18f54a4e323d58 Merge: ffcd490cb4 40bc77d9a6 Author: Andrea Corallo Date: Wed Dec 23 19:49:58 2020 +0100 Merge remote-tracking branch 'savannah/master' into HEAD commit ffcd490cb49ba86d625288ea425d98e8cac22a05 Author: Andrea Corallo Date: Wed Dec 23 15:51:55 2020 +0100 Negate only values while constraining variables (bug#45376) * lisp/emacs-lisp/comp-cstr.el (comp-cstr-value-negation): New function. * lisp/emacs-lisp/comp.el (comp-fwprop-insn): Use `comp-cstr-value-negation'. * test/src/comp-test-funcs.el (comp-test-45376-1-f): Rename. (comp-test-45376-2-f): New funcion. * test/src/comp-tests.el (bug-45376-1): Rename test. (bug-45376-2): Add test. diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el index 92c981f5ac..8b5639c8a4 100644 --- a/lisp/emacs-lisp/comp-cstr.el +++ b/lisp/emacs-lisp/comp-cstr.el @@ -701,6 +701,20 @@ DST is returned." (neg dst) (not (neg src))) dst)) +(defun comp-cstr-value-negation (dst src) + "Negate values in SRC setting the result in DST. +DST is returned." + (with-comp-cstr-accessors + (if (or (valset src) (range src)) + (setf (typeset dst) () + (valset dst) (valset src) + (range dst) (range src) + (neg dst) (not (neg src))) + (setf (typeset dst) (typeset src) + (valset dst) () + (range dst) ())) + dst)) + (defun comp-cstr-negation-make (src) "Negate SRC and return a new constraint." (comp-cstr-negation (make-comp-cstr) src)) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 485e5dc6ad..6ed50dc012 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2534,7 +2534,7 @@ Fold the call in case." (not ;; Prevent double negation! (unless (comp-cstr-neg (car operands)) - (comp-cstr-negation lval (car operands)))))) + (comp-cstr-value-negation lval (car operands)))))) (`(setimm ,lval ,v) (setf (comp-mvar-value lval) v)) (`(phi ,lval . ,rest) diff --git a/test/src/comp-test-funcs.el b/test/src/comp-test-funcs.el index d6bcfca2d9..7731e6547b 100644 --- a/test/src/comp-test-funcs.el +++ b/test/src/comp-test-funcs.el @@ -417,7 +417,7 @@ (setq args (cons (substring arg start pos) args)))) args)) -(defun comp-test-45376-f () +(defun comp-test-45376-1-f () ;; Reduced from `eshell-ls-find-column-lengths'. (let* (res (len 2) @@ -431,6 +431,24 @@ i (1+ i))) res)) +(defun comp-test-45376-2-f () + ;; Also reduced from `eshell-ls-find-column-lengths'. + (let* ((x 1) + res) + (while x + (let* ((y 4) + (i 0)) + (while (> y 0) + (when (= i x) + (setq i 0)) + (setf res (cons i res)) + (setq y (1- y) + i (1+ i))) + (if (>= x 3) + (setq x nil) + (setq x (1+ x))))) + res)) + ;;;;;;;;;;;;;;;;;;;; ;; Tromey's tests ;; diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 5f2d702fca..e0d4bf8df5 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -409,9 +409,13 @@ https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-03/msg00914.html." "Broken call args assumptions lead to infinite loop." (should (equal (comp-test-assume-in-loop-1-f "cd") '("cd")))) -(comp-deftest bug-45376 () +(comp-deftest bug-45376-1 () "" - (should (equal (comp-test-45376-f) '(1 0)))) + (should (equal (comp-test-45376-1-f) '(1 0)))) + +(comp-deftest bug-45376-2 () + "" + (should (equal (comp-test-45376-2-f) '(0 2 1 0 1 0 1 0 0 0 0 0)))) (defvar comp-test-primitive-advice) (comp-deftest primitive-advice () commit 0a89ed7a962e22892e9c700cfca188197af2a6ad Author: Andrea Corallo Date: Wed Dec 23 14:03:54 2020 +0100 * Fix non range cstr union operation * lisp/emacs-lisp/comp-cstr.el (comp-cstr-union-homogeneous): Add range parameter and handle the non range case. (comp-cstr-union-1-no-mem, comp-cstr-intersection-no-mem): Update `comp-cstr-union-homogeneous' call sites. diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el index 480d15616a..92c981f5ac 100644 --- a/lisp/emacs-lisp/comp-cstr.el +++ b/lisp/emacs-lisp/comp-cstr.el @@ -383,8 +383,9 @@ All SRCS constraints must be homogeneously negated or non-negated." dst) -(defun comp-cstr-union-homogeneous (dst &rest srcs) +(defun comp-cstr-union-homogeneous (range dst &rest srcs) "Combine SRCS by union set operation setting the result in DST. +Do range propagation when RANGE is non-nil. All SRCS constraints must be homogeneously negated or non-negated. DST is returned." (apply #'comp-cstr-union-homogeneous-no-range dst srcs) @@ -397,9 +398,10 @@ DST is returned." (when (cl-notany (lambda (x) (comp-subtype-p 'integer x)) (comp-cstr-typeset dst)) - ;; TODO memoize? - (apply #'comp-range-union - (mapcar #'comp-cstr-range srcs)))) + (if range + (apply #'comp-range-union + (mapcar #'comp-cstr-range srcs)) + '((- . +))))) dst) (cl-defun comp-cstr-union-1-no-mem (range &rest srcs) @@ -419,17 +421,17 @@ DST is returned." ;; Check first if we are in the simple case of all input non-negate ;; or negated so we don't have to cons. (when-let ((res (comp-cstrs-homogeneous srcs))) - (apply #'comp-cstr-union-homogeneous dst srcs) + (apply #'comp-cstr-union-homogeneous range dst srcs) (cl-return-from comp-cstr-union-1-no-mem dst)) ;; Some are negated and some are not (cl-multiple-value-bind (positives negatives) (comp-split-pos-neg srcs) - (let* ((pos (apply #'comp-cstr-union-homogeneous + (let* ((pos (apply #'comp-cstr-union-homogeneous range (make-comp-cstr) positives)) ;; We'll always use neg as result as this is almost ;; always necessary for describing open intervals ;; resulting from negated constraints. - (neg (apply #'comp-cstr-union-homogeneous + (neg (apply #'comp-cstr-union-homogeneous range (make-comp-cstr :neg t) negatives))) ;; Type propagation. (when (and (typeset pos) @@ -586,7 +588,7 @@ Non memoized version of `comp-cstr-intersection-no-mem'." (cl-return-from comp-cstr-intersection-no-mem dst))) (when-let ((res (comp-cstrs-homogeneous srcs))) (if (eq res 'neg) - (apply #'comp-cstr-union-homogeneous dst srcs) + (apply #'comp-cstr-union-homogeneous t dst srcs) (apply #'comp-cstr-intersection-homogeneous dst srcs)) (cl-return-from comp-cstr-intersection-no-mem dst)) commit c90aa68d90b1c5805d3d6327a058098d938ac72f Author: Andrea Corallo Date: Wed Dec 23 11:47:36 2020 +0100 * Follow cstr basic blocks to perform latch recognition * lisp/emacs-lisp/comp.el (comp-fwprop-insn): Fix latch recognition. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 2f8587909e..485e5dc6ad 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2540,9 +2540,12 @@ Fold the call in case." (`(phi ,lval . ,rest) (let* ((from-latch (cl-some (lambda (x) - (comp-latch-p - (gethash (cdr x) - (comp-func-blocks comp-func)))) + (let* ((bb-name (cadr x)) + (bb (gethash bb-name + (comp-func-blocks comp-func)))) + (or (comp-latch-p bb) + (when (comp-block-cstr-p bb) + (comp-latch-p (car (comp-block-preds bb))))))) rest)) (prop-fn (if from-latch #'comp-cstr-union-no-range commit fd8dd75a71eef796ba8fb1d2604fd615bebaae42 Author: Andrea Corallo Date: Wed Dec 23 10:46:33 2020 +0100 Make input constraints into memoization hash immutable (bug#45376) * lisp/emacs-lisp/comp-cstr.el (comp-cstr-union-1) (comp-cstr-intersection): Copy input before soting it into the memoization hash table. diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el index aaeb9cf3e9..480d15616a 100644 --- a/lisp/emacs-lisp/comp-cstr.el +++ b/lisp/emacs-lisp/comp-cstr.el @@ -507,7 +507,7 @@ DST is returned." (comp-cstr-ctxt-union-1-mem-no-range comp-ctxt))) (res (or (gethash srcs mem-h) (puthash - srcs + (mapcar #'comp-cstr-copy srcs) (apply #'comp-cstr-union-1-no-mem range srcs) mem-h)))) (setf (typeset dst) (typeset res) @@ -676,7 +676,7 @@ DST is returned." (let* ((mem-h (comp-cstr-ctxt-intersection-mem comp-ctxt)) (res (or (gethash srcs mem-h) (puthash - srcs + (mapcar #'comp-cstr-copy srcs) (apply #'comp-cstr-intersection-no-mem srcs) mem-h)))) (setf (typeset dst) (typeset res) diff --git a/test/src/comp-test-funcs.el b/test/src/comp-test-funcs.el index a2663eaf9c..d6bcfca2d9 100644 --- a/test/src/comp-test-funcs.el +++ b/test/src/comp-test-funcs.el @@ -417,6 +417,20 @@ (setq args (cons (substring arg start pos) args)))) args)) +(defun comp-test-45376-f () + ;; Reduced from `eshell-ls-find-column-lengths'. + (let* (res + (len 2) + (i 0) + (j 0)) + (while (< j len) + (if (= i len) + (setq i 0)) + (setq res (cons i res) + j (1+ j) + i (1+ i))) + res)) + ;;;;;;;;;;;;;;;;;;;; ;; Tromey's tests ;; diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 0594a4e086..5f2d702fca 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -409,6 +409,10 @@ https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-03/msg00914.html." "Broken call args assumptions lead to infinite loop." (should (equal (comp-test-assume-in-loop-1-f "cd") '("cd")))) +(comp-deftest bug-45376 () + "" + (should (equal (comp-test-45376-f) '(1 0)))) + (defvar comp-test-primitive-advice) (comp-deftest primitive-advice () "Test effectiveness of primitive advicing." commit 2a22fa8b68d18b83b0a20be66b9123454bf7b6e5 Author: Andrea Corallo Date: Wed Dec 23 10:48:29 2020 +0100 * lisp/emacs-lisp/comp-cstr.el (comp-cstr-copy): Tweak for perf. diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el index 22d3958aed..aaeb9cf3e9 100644 --- a/lisp/emacs-lisp/comp-cstr.el +++ b/lisp/emacs-lisp/comp-cstr.el @@ -113,10 +113,10 @@ Integer values are handled in the `range' slot.") (defun comp-cstr-copy (cstr) "Return a deep copy of CSTR." (with-comp-cstr-accessors - (make-comp-cstr :typeset (copy-tree (typeset cstr)) - :valset (copy-tree (valset cstr)) + (make-comp-cstr :typeset (copy-sequence (typeset cstr)) + :valset (copy-sequence (valset cstr)) :range (copy-tree (range cstr)) - :neg (copy-tree (neg cstr))))) + :neg (neg cstr)))) (defsubst comp-cstr-empty-p (cstr) "Return t if CSTR is equivalent to the `nil' type specifier or nil otherwise." commit 433ae7b0a5cedbcd7b0a1daf12846e38f00fd111 Author: Liāu, Kiong-Gē 廖宮毅 Date: Tue Dec 22 20:02:50 2020 +0100 Fix --with-nativecomp Windows build (bug#45303) Liāu, Kiong-Gē 廖宮毅 * src/comp.c (eln_load_path_final_clean_up): Fix argument order. * nt/mingw-cfg.site (ac_cv_func_strsignal): Force `ac_cv_func_strsignal' to no. Copyright-paperwork-exempt: yes diff --git a/nt/mingw-cfg.site b/nt/mingw-cfg.site index 4a77cc20b4..a2c9399697 100644 --- a/nt/mingw-cfg.site +++ b/nt/mingw-cfg.site @@ -156,3 +156,7 @@ gl_cv_func_copy_file_range=yes # We don't want to build Emacs so it depends on bcrypt.dll, since then # it will refuse to start on systems where that DLL is absent. gl_cv_lib_assume_bcrypt=no +# Force 'ac_cv_func_strsignal' to no as mingw64 libgccjit exports this +# symbol erroneously +# . +ac_cv_func_strsignal=no diff --git a/src/comp.c b/src/comp.c index 70f61bfbe1..166c75bea0 100644 --- a/src/comp.c +++ b/src/comp.c @@ -4534,7 +4534,7 @@ eln_load_path_final_clean_up (void) concat2 (XCAR (dir_tail), Vcomp_native_version_dir), Qt, build_string ("\\.eln\\.old\\'"), Qnil, - Qt, Qnil, return_nil); + Qnil, Qt, return_nil); FOR_EACH_TAIL (files_in_dir) Fdelete_file (XCAR (files_in_dir), Qnil); } commit 9676e4d7766cea647a4e2b9e27fad97479b418de Author: Andrea Corallo Date: Fri Dec 18 15:22:41 2020 +0100 * Fix a test in auth-source-tests.el * test/lisp/auth-source-tests.el (auth-source-test-secrets-create-secret): Redefine `read-string' respecting the original number of arguments. diff --git a/test/lisp/auth-source-tests.el b/test/lisp/auth-source-tests.el index deb1b91aab..4c3005c3ef 100644 --- a/test/lisp/auth-source-tests.el +++ b/test/lisp/auth-source-tests.el @@ -320,7 +320,8 @@ ;; Redefine `read-*' in order to avoid interactive input. (cl-letf (((symbol-function 'read-passwd) (lambda (_) passwd)) ((symbol-function 'read-string) - (lambda (_prompt _initial _history default) default))) + (lambda (_prompt _initial _history default _inherit-input-method) + default))) (setq auth-info (car (auth-source-search :max 1 :host host :require '(:user :secret) :create t)))) commit ebf8963a9181ab4e87141c2603df996f49389765 Author: Andrea Corallo Date: Sat Dec 19 15:11:30 2020 +0100 * Fix a bunch of known type specifiers * lisp/emacs-lisp/comp.el (comp-known-type-specifiers): Fixes for: =, string-search, substring. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 5345e20bfc..2f8587909e 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -198,7 +198,7 @@ Useful to hook into pass checkers.") (symbol-name (function (symbol) string)) (eq (function (t t) boolean)) (eql (function (t t) boolean)) - (= (function ((or number marker) (or number marker)) boolean)) + (= (function ((or number marker) &rest (or number marker)) boolean)) (/= (function ((or number marker) (or number marker)) boolean)) (< (function ((or number marker) &rest (or number marker)) boolean)) (<= (function ((or number marker) &rest (or number marker)) boolean)) @@ -233,11 +233,11 @@ Useful to hook into pass checkers.") (string-equal (function ((or string symbol) (or string symbol)) boolean)) (string< (function ((or string symbol) (or string symbol)) boolean)) (string-lessp (function ((or string symbol) (or string symbol)) boolean)) - (string-search (function (string string) (or integer null))) + (string-search (function (string string &optional integer) integer)) (string-to-char (function (string) integer)) (string-to-number (function (string &optional integer) number)) (string-to-syntax (function (string) cons)) - (substring (function (string &optional integer integer) string)) + (substring (function ((or string vector) &optional integer integer) (or string vector))) (sxhash (function (t) integer)) (sxhash-equal (function (t) integer)) (sxhash-eq (function (t) integer)) @@ -253,7 +253,6 @@ Useful to hook into pass checkers.") (string-to-multibyte (function (string) string)) (tan (function (number) float)) (time-convert (function (t &optional (or boolean integer)) cons)) - (truncate (function (number) integer)) (unibyte-char-to-multibyte (function (fixnum) fixnum)) ;; byte is fixnum (upcase (function ((or fixnum string)) (or fixnum string))) (user-full-name (function (&optional integer) string)) commit 5376563517f2235b8b79f661c213fd74dd62b654 Author: Andrea Corallo Date: Sat Dec 19 11:56:15 2020 +0100 Fix `comp-add-call-cstr' and add a test * lisp/emacs-lisp/comp.el (comp-add-call-cstr): Fix it. * test/src/comp-tests.el (assume-in-loop-1): New test. * test/src/comp-test-funcs.el (comp-test-assume-in-loop-1-f): New function. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 895e1ac33e..5345e20bfc 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2017,21 +2017,24 @@ TARGET-BB-SYM is the symbol name of the target block." (pcase insn (`(set ,lhs (,(pred comp-call-op-p) ,f . ,args)) (when-let ((cstr-f (gethash f comp-known-func-cstr-h))) - (cl-values cstr-f lhs args))) + (cl-values f cstr-f lhs args))) (`(,(pred comp-call-op-p) ,f . ,args) (when-let ((cstr-f (gethash f comp-known-func-cstr-h))) - (cl-values cstr-f nil args)))))) - (cl-multiple-value-bind (cstr-f lhs args) match + (cl-values f cstr-f nil args)))))) + (cl-multiple-value-bind (f cstr-f lhs args) match (cl-loop + with gen = (comp-lambda-list-gen (comp-cstr-f-args cstr-f)) for arg in args - for gen = (comp-lambda-list-gen (comp-cstr-f-args cstr-f)) for cstr = (funcall gen) for target = (comp-cond-cstrs-target-mvar arg insn bb) + unless (comp-cstr-p cstr) + do (signal 'native-ice + (list "Incoherent type specifier for function" f)) when (and target (or (null lhs) (not (eql (comp-mvar-slot lhs) (comp-mvar-slot target))))) - do (comp-emit-call-cstr target insn-cell cstr))))))) + do (comp-emit-call-cstr target insn-cell cstr))))))) (defun comp-add-cstrs (_) "Rewrite conditional branches adding appropriate 'assume' insns. diff --git a/test/src/comp-test-funcs.el b/test/src/comp-test-funcs.el index 7f70fc2460..a2663eaf9c 100644 --- a/test/src/comp-test-funcs.el +++ b/test/src/comp-test-funcs.el @@ -405,6 +405,18 @@ ;; collection is t, not (member t)! (member value collection))) +(defun comp-test-assume-in-loop-1-f (arg) + ;; Reduced from `comint-delim-arg'. + (let ((args nil) + (pos 0) + (len (length arg))) + (while (< pos len) + (let ((start pos)) + (while (< pos len) + (setq pos (1+ pos))) + (setq args (cons (substring arg start pos) args)))) + args)) + ;;;;;;;;;;;;;;;;;;;; ;; Tromey's tests ;; diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index eeff599de4..0594a4e086 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -405,6 +405,10 @@ https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-03/msg00914.html." "In fwprop assumtions (not (not (member x))) /= (member x)." (should-not (comp-test-assume-double-neg-f "bar" "foo"))) +(comp-deftest assume-in-loop-1 () + "Broken call args assumptions lead to infinite loop." + (should (equal (comp-test-assume-in-loop-1-f "cd") '("cd")))) + (defvar comp-test-primitive-advice) (comp-deftest primitive-advice () "Test effectiveness of primitive advicing." commit 6f3570cd4a615caa02c3d86320049a5631ab9b25 Author: Andrea Corallo Date: Fri Dec 18 18:37:16 2020 +0100 Fix value type inference for doubly negate constraints * lisp/emacs-lisp/comp.el (comp-fwprop-insn): Do not propagate in case of double negation. * test/src/comp-test-funcs.el (comp-test-assume-double-neg-f): New function. * test/src/comp-tests.el (assume-double-neg): New test. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 5d2f8d412f..895e1ac33e 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2530,7 +2530,9 @@ Fold the call in case." (and (apply #'comp-cstr-intersection lval operands)) (not - (comp-cstr-negation lval (car operands))))) + ;; Prevent double negation! + (unless (comp-cstr-neg (car operands)) + (comp-cstr-negation lval (car operands)))))) (`(setimm ,lval ,v) (setf (comp-mvar-value lval) v)) (`(phi ,lval . ,rest) diff --git a/test/src/comp-test-funcs.el b/test/src/comp-test-funcs.el index 5fc032b127..7f70fc2460 100644 --- a/test/src/comp-test-funcs.el +++ b/test/src/comp-test-funcs.el @@ -395,6 +395,16 @@ (1 " ➊") (2 " ➋") (3 " ➌") (4 " ➍") (5 " ➎") (6 " ➏") (7 " ➐") (8 " ➑") (9 " ➒") (10 " ➓") (_ ""))) +(defun comp-test-assume-double-neg-f (collection value) + ;; Reduced from `auth-source-search-collection'. + (when (atom collection) + (setq collection (list collection))) + (or (eq value t) + ;; value is (not (member t)) + (eq collection value) + ;; collection is t, not (member t)! + (member value collection))) + ;;;;;;;;;;;;;;;;;;;; ;; Tromey's tests ;; diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 8e069fb308..eeff599de4 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -401,6 +401,10 @@ https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-03/msg00914.html." " (should (string= " ➊" (comp-test-45342-f 1)))) +(comp-deftest assume-double-neg () + "In fwprop assumtions (not (not (member x))) /= (member x)." + (should-not (comp-test-assume-double-neg-f "bar" "foo"))) + (defvar comp-test-primitive-advice) (comp-deftest primitive-advice () "Test effectiveness of primitive advicing." commit 9bbe6eab6c160a454f2705c00ff3aea7f0c6e6c1 Author: Andrea Corallo Date: Fri Dec 18 17:44:49 2020 +0100 Fix native compiler tests when they are bytecompiled * test/lisp/emacs-lisp/comp-cstr-tests.el (comp-cstr-test-ts) (comp-cstr-typespec-test, comp-cstr-typespec-tests-alist): Eval also at compile time. * test/src/comp-tests.el (comp-tests-type-spec-tests) (comp-tests-define-type-spec-test): Likewise. diff --git a/test/lisp/emacs-lisp/comp-cstr-tests.el b/test/lisp/emacs-lisp/comp-cstr-tests.el index b38573ca33..834f4401d9 100644 --- a/test/lisp/emacs-lisp/comp-cstr-tests.el +++ b/test/lisp/emacs-lisp/comp-cstr-tests.el @@ -29,180 +29,182 @@ (require 'cl-lib) (require 'comp-cstr) -(defun comp-cstr-test-ts (type-spec) - "Create a constraint from TYPE-SPEC and convert it back to type specifier." - (let ((comp-ctxt (make-comp-cstr-ctxt))) - (comp-cstr-to-type-spec (comp-type-spec-to-cstr type-spec)))) - -(defun comp-cstr-typespec-test (number type-spec expected-type-spec) - `(ert-deftest ,(intern (concat "comp-cstr-test-" (int-to-string number))) () - (should (equal (comp-cstr-test-ts ',type-spec) - ',expected-type-spec)))) - -(defconst comp-cstr-typespec-tests-alist - `(;; 1 - (symbol . symbol) - ;; 2 - ((or string array) . array) - ;; 3 - ((or symbol number) . (or number symbol)) - ;; 4 - ((or cons atom) . (or atom cons)) ;; SBCL return T - ;; 5 - ((or integer number) . number) - ;; 6 - ((or (or integer symbol) number) . (or number symbol)) - ;; 7 - ((or (or integer symbol) (or number list)) . (or list number symbol)) - ;; 8 - ((or (or integer number) nil) . number) - ;; 9 - ((member foo) . (member foo)) - ;; 10 - ((member foo bar) . (member bar foo)) - ;; 11 - ((or (member foo) (member bar)) . (member bar foo)) - ;; 12 - ((or (member foo) symbol) . symbol) ;; SBCL return (OR SYMBOL (MEMBER FOO)) - ;; 13 - ((or (member foo) number) . (or (member foo) number)) - ;; 14 - ((or (integer 1 3) number) . number) - ;; 15 - (integer . integer) - ;; 16 - ((integer 1 2) . (integer 1 2)) - ;; 17 - ((or (integer -1 0) (integer 3 4)) . (or (integer -1 0) (integer 3 4))) - ;; 18 - ((or (integer -1 2) (integer 3 4)) . (integer -1 4)) - ;; 19 - ((or (integer -1 3) (integer 3 4)) . (integer -1 4)) - ;; 20 - ((or (integer -1 4) (integer 3 4)) . (integer -1 4)) - ;; 21 - ((or (integer -1 5) (integer 3 4)) . (integer -1 5)) - ;; 22 - ((or (integer -1 *) (integer 3 4)) . (integer -1 *)) - ;; 23 - ((or (integer -1 2) (integer * 4)) . (integer * 4)) - ;; 24 - ((and string array) . string) - ;; 25 - ((and cons atom) . nil) - ;; 26 - ((and (member foo) (member foo bar baz)) . (member foo)) - ;; 27 - ((and (member foo) (member bar)) . nil) - ;; 28 - ((and (member foo) symbol) . (member foo)) - ;; 29 - ((and (member foo) string) . nil) - ;; 30 - ((and (member foo) (integer 1 2)) . nil) - ;; 31 - ((and (member 1 2) (member 3 2)) . (member 2)) - ;; 32 - ((and number (integer 1 2)) . (integer 1 2)) - ;; 33 - ((and integer (integer 1 2)) . (integer 1 2)) - ;; 34 - ((and (integer -1 0) (integer 3 5)) . nil) - ;; 35 - ((and (integer -1 2) (integer 3 5)) . nil) - ;; 36 - ((and (integer -1 3) (integer 3 5)) . (integer 3 3)) - ;; 37 - ((and (integer -1 4) (integer 3 5)) . (integer 3 4)) - ;; 38 - ((and (integer -1 5) nil) . nil) - ;; 39 - ((not symbol) . (not symbol)) - ;; 40 - ((or (member foo) (not (member foo bar))) . (not (member bar))) - ;; 41 - ((or (member foo bar) (not (member foo))) . t) - ;; 42 - ((or symbol (not sequence)) . (not sequence)) - ;; 43 - ((or symbol (not symbol)) . t) - ;; 44 - ((or symbol (not sequence)) . (not sequence)) - ;; 45 Conservative. - ((or vector (not sequence)) . t) - ;; 46 - ((or (integer 1 10) (not (integer * 5))) . (not (integer * 0))) - ;; 47 - ((or symbol (integer 1 10) (not (integer * 5))) . (not (integer * 0))) - ;; 48 - ((or (not symbol) (integer 1 10) (not (integer * 5))) . (not (or symbol (integer * 0)))) - ;; 49 - ((or symbol (not (member foo))) . (not (member foo))) - ;; 50 - ((or (not symbol) (not (member foo))) . (not symbol)) - ;; 51 Conservative. - ((or (not (member foo)) string) . (not (member foo))) - ;; 52 Conservative. - ((or (member foo) (not string)) . (not string)) - ;; 53 - ((or (not (integer 1 2)) integer) . integer) - ;; 54 - ((or (not (integer 1 2)) (not integer)) . (not integer)) - ;; 55 - ((or (integer 1 2) (not integer)) . (not (or (integer * 0) (integer 3 *)))) - ;; 56 - ((or number (not (integer 1 2))) . t) - ;; 57 - ((or atom (not (integer 1 2))) . t) - ;; 58 - ((or atom (not (member foo))) . t) - ;; 59 - ((and symbol (not cons)) . symbol) - ;; 60 - ((and symbol (not symbol)) . nil) - ;; 61 - ((and atom (not symbol)) . atom) - ;; 62 - ((and atom (not string)) . (or array sequence atom)) - ;; 63 Conservative - ((and symbol (not (member foo))) . symbol) - ;; 64 Conservative - ((and symbol (not (member 3))) . symbol) - ;; 65 - ((and (not (member foo)) (integer 1 10)) . (integer 1 10)) - ;; 66 - ((and (member foo) (not (integer 1 10))) . (member foo)) - ;; 67 - ((and t (not (member foo))) . (not (member foo))) - ;; 68 - ((and integer (not (integer 3 4))) . (or (integer * 2) (integer 5 *))) - ;; 69 - ((and (integer 0 20) (not (integer 5 10))) . (or (integer 0 4) (integer 11 20))) - ;; 70 - ((and (not (member a)) (not (member b))) . (not (member b a))) - ;; 71 - ((and (not boolean) (not (member b))) . (not (or (member b) boolean))) - ;; 72 - ((and t (integer 1 1)) . (integer 1 1)) - ;; 73 - ((not (integer -1 5)) . (not (integer -1 5))) - ;; 74 - ((and boolean (or number marker)) . nil) - ;; 75 - ((and atom (or number marker)) . (or marker number)) - ;; 76 - ((and symbol (or number marker)) . nil) - ;; 77 - ((and (or symbol string) (or number marker)) . nil) - ;; 78 - ((and t t) . t) - ;; 80 - ((and (or marker number) (integer 0 0)) . (integer 0 0)) - ;; 81 - ((and t (not t)) . nil) - ;; 82 - ((or (integer 1 1) (not (integer 1 1))) . t)) - "Alist type specifier -> expected type specifier.") +(cl-eval-when (compile eval load) + + (defun comp-cstr-test-ts (type-spec) + "Create a constraint from TYPE-SPEC and convert it back to type specifier." + (let ((comp-ctxt (make-comp-cstr-ctxt))) + (comp-cstr-to-type-spec (comp-type-spec-to-cstr type-spec)))) + + (defun comp-cstr-typespec-test (number type-spec expected-type-spec) + `(ert-deftest ,(intern (concat "comp-cstr-test-" (int-to-string number))) () + (should (equal (comp-cstr-test-ts ',type-spec) + ',expected-type-spec)))) + + (defconst comp-cstr-typespec-tests-alist + `(;; 1 + (symbol . symbol) + ;; 2 + ((or string array) . array) + ;; 3 + ((or symbol number) . (or number symbol)) + ;; 4 + ((or cons atom) . (or atom cons)) ;; SBCL return T + ;; 5 + ((or integer number) . number) + ;; 6 + ((or (or integer symbol) number) . (or number symbol)) + ;; 7 + ((or (or integer symbol) (or number list)) . (or list number symbol)) + ;; 8 + ((or (or integer number) nil) . number) + ;; 9 + ((member foo) . (member foo)) + ;; 10 + ((member foo bar) . (member bar foo)) + ;; 11 + ((or (member foo) (member bar)) . (member bar foo)) + ;; 12 + ((or (member foo) symbol) . symbol) ;; SBCL return (OR SYMBOL (MEMBER FOO)) + ;; 13 + ((or (member foo) number) . (or (member foo) number)) + ;; 14 + ((or (integer 1 3) number) . number) + ;; 15 + (integer . integer) + ;; 16 + ((integer 1 2) . (integer 1 2)) + ;; 17 + ((or (integer -1 0) (integer 3 4)) . (or (integer -1 0) (integer 3 4))) + ;; 18 + ((or (integer -1 2) (integer 3 4)) . (integer -1 4)) + ;; 19 + ((or (integer -1 3) (integer 3 4)) . (integer -1 4)) + ;; 20 + ((or (integer -1 4) (integer 3 4)) . (integer -1 4)) + ;; 21 + ((or (integer -1 5) (integer 3 4)) . (integer -1 5)) + ;; 22 + ((or (integer -1 *) (integer 3 4)) . (integer -1 *)) + ;; 23 + ((or (integer -1 2) (integer * 4)) . (integer * 4)) + ;; 24 + ((and string array) . string) + ;; 25 + ((and cons atom) . nil) + ;; 26 + ((and (member foo) (member foo bar baz)) . (member foo)) + ;; 27 + ((and (member foo) (member bar)) . nil) + ;; 28 + ((and (member foo) symbol) . (member foo)) + ;; 29 + ((and (member foo) string) . nil) + ;; 30 + ((and (member foo) (integer 1 2)) . nil) + ;; 31 + ((and (member 1 2) (member 3 2)) . (member 2)) + ;; 32 + ((and number (integer 1 2)) . (integer 1 2)) + ;; 33 + ((and integer (integer 1 2)) . (integer 1 2)) + ;; 34 + ((and (integer -1 0) (integer 3 5)) . nil) + ;; 35 + ((and (integer -1 2) (integer 3 5)) . nil) + ;; 36 + ((and (integer -1 3) (integer 3 5)) . (integer 3 3)) + ;; 37 + ((and (integer -1 4) (integer 3 5)) . (integer 3 4)) + ;; 38 + ((and (integer -1 5) nil) . nil) + ;; 39 + ((not symbol) . (not symbol)) + ;; 40 + ((or (member foo) (not (member foo bar))) . (not (member bar))) + ;; 41 + ((or (member foo bar) (not (member foo))) . t) + ;; 42 + ((or symbol (not sequence)) . (not sequence)) + ;; 43 + ((or symbol (not symbol)) . t) + ;; 44 + ((or symbol (not sequence)) . (not sequence)) + ;; 45 Conservative. + ((or vector (not sequence)) . t) + ;; 46 + ((or (integer 1 10) (not (integer * 5))) . (not (integer * 0))) + ;; 47 + ((or symbol (integer 1 10) (not (integer * 5))) . (not (integer * 0))) + ;; 48 + ((or (not symbol) (integer 1 10) (not (integer * 5))) . (not (or symbol (integer * 0)))) + ;; 49 + ((or symbol (not (member foo))) . (not (member foo))) + ;; 50 + ((or (not symbol) (not (member foo))) . (not symbol)) + ;; 51 Conservative. + ((or (not (member foo)) string) . (not (member foo))) + ;; 52 Conservative. + ((or (member foo) (not string)) . (not string)) + ;; 53 + ((or (not (integer 1 2)) integer) . integer) + ;; 54 + ((or (not (integer 1 2)) (not integer)) . (not integer)) + ;; 55 + ((or (integer 1 2) (not integer)) . (not (or (integer * 0) (integer 3 *)))) + ;; 56 + ((or number (not (integer 1 2))) . t) + ;; 57 + ((or atom (not (integer 1 2))) . t) + ;; 58 + ((or atom (not (member foo))) . t) + ;; 59 + ((and symbol (not cons)) . symbol) + ;; 60 + ((and symbol (not symbol)) . nil) + ;; 61 + ((and atom (not symbol)) . atom) + ;; 62 + ((and atom (not string)) . (or array sequence atom)) + ;; 63 Conservative + ((and symbol (not (member foo))) . symbol) + ;; 64 Conservative + ((and symbol (not (member 3))) . symbol) + ;; 65 + ((and (not (member foo)) (integer 1 10)) . (integer 1 10)) + ;; 66 + ((and (member foo) (not (integer 1 10))) . (member foo)) + ;; 67 + ((and t (not (member foo))) . (not (member foo))) + ;; 68 + ((and integer (not (integer 3 4))) . (or (integer * 2) (integer 5 *))) + ;; 69 + ((and (integer 0 20) (not (integer 5 10))) . (or (integer 0 4) (integer 11 20))) + ;; 70 + ((and (not (member a)) (not (member b))) . (not (member b a))) + ;; 71 + ((and (not boolean) (not (member b))) . (not (or (member b) boolean))) + ;; 72 + ((and t (integer 1 1)) . (integer 1 1)) + ;; 73 + ((not (integer -1 5)) . (not (integer -1 5))) + ;; 74 + ((and boolean (or number marker)) . nil) + ;; 75 + ((and atom (or number marker)) . (or marker number)) + ;; 76 + ((and symbol (or number marker)) . nil) + ;; 77 + ((and (or symbol string) (or number marker)) . nil) + ;; 78 + ((and t t) . t) + ;; 80 + ((and (or marker number) (integer 0 0)) . (integer 0 0)) + ;; 81 + ((and t (not t)) . nil) + ;; 82 + ((or (integer 1 1) (not (integer 1 1))) . t)) + "Alist type specifier -> expected type specifier.")) (defmacro comp-cstr-synthesize-tests () "Generate all tests from `comp-cstr-typespec-tests-alist'." diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index a3e887bde9..8e069fb308 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -789,142 +789,143 @@ Return a list of results." (eval func-form t) (native-compile (cadr func-form)))) -(defconst comp-tests-type-spec-tests - `( - ;; 1 - ((defun comp-tests-ret-type-spec-f (x) - x) - t) - - ;; 2 - ((defun comp-tests-ret-type-spec-f () - 1) - (integer 1 1)) - - ;; 3 - ((defun comp-tests-ret-type-spec-f (x) - (if x 1 3)) - (or (integer 1 1) (integer 3 3))) - - ;; 4 - ((defun comp-tests-ret-type-spec-f (x) - (let (y) +(cl-eval-when (compile eval load) + (defconst comp-tests-type-spec-tests + `( + ;; 1 + ((defun comp-tests-ret-type-spec-f (x) + x) + t) + + ;; 2 + ((defun comp-tests-ret-type-spec-f () + 1) + (integer 1 1)) + + ;; 3 + ((defun comp-tests-ret-type-spec-f (x) + (if x 1 3)) + (or (integer 1 1) (integer 3 3))) + + ;; 4 + ((defun comp-tests-ret-type-spec-f (x) + (let (y) + (if x + (setf y 1) + (setf y 2)) + y)) + (integer 1 2)) + + ;; 5 + ((defun comp-tests-ret-type-spec-f (x) + (let (y) + (if x + (setf y 1) + (setf y 3)) + y)) + (or (integer 1 1) (integer 3 3))) + + + ;; 6 + ((defun comp-tests-ret-type-spec-f (x) (if x - (setf y 1) - (setf y 2)) - y)) - (integer 1 2)) - - ;; 5 - ((defun comp-tests-ret-type-spec-f (x) - (let (y) + (list x) + 3)) + (or cons (integer 3 3))) + + ;; 7 + ((defun comp-tests-ret-type-spec-f (x) (if x - (setf y 1) - (setf y 3)) - y)) - (or (integer 1 1) (integer 3 3))) - - - ;; 6 - ((defun comp-tests-ret-type-spec-f (x) - (if x - (list x) - 3)) - (or cons (integer 3 3))) - - ;; 7 - ((defun comp-tests-ret-type-spec-f (x) - (if x - 'foo - 3)) - (or (member foo) (integer 3 3))) - - ;; 8 - ((defun comp-tests-ret-type-spec-f (x) - (if (eq x 3) - x - 'foo)) - (or (member foo) (integer 3 3))) - - ;; 9 - ((defun comp-tests-ret-type-spec-f (x) - (if (eq 3 x) - x - 'foo)) - (or (member foo) (integer 3 3))) - - ;; 10 - ((defun comp-tests-ret-type-spec-f (x) - (if (= x 3) - x - 'foo)) - (or (member foo) (integer 3 3))) - - ;; 11 - ((defun comp-tests-ret-type-spec-f (x) - (if (= 3 x) - x - 'foo)) - (or (member foo) (integer 3 3))) - - ;; 12 - ((defun comp-tests-ret-type-spec-8-3-f (x) - (if (= x 3) - 'foo - x)) - (or (member foo) marker number)) - - ;; 13 - ((defun comp-tests-ret-type-spec-8-4-f (x y) - (if (= x y) - x - 'foo)) - (or (member foo) marker number)) - - ;; 14 - ((defun comp-tests-ret-type-spec-9-1-f (x) - (comp-hint-fixnum x)) - (integer ,most-negative-fixnum ,most-positive-fixnum)) - - ;; 15 - ((defun comp-tests-ret-type-spec-f (x) - (comp-hint-cons x)) - cons) - - ;; 16 - ((defun comp-tests-ret-type-spec-f (x) - (let (y) - (when x - (setf y 4)) - y)) - (or null (integer 4 4))) - - ;; 17 - ((defun comp-tests-ret-type-spec-f () - (let (x - (y 3)) - (setf x y) - y)) - (integer 3 3)) - - ;; 18 - ((defun comp-tests-ret-type-spec-f (x) - (let ((y 3)) - (when x - (setf y x)) - y)) - t) - - ;; 19 - ((defun comp-tests-ret-type-spec-f (x y) - (eq x y)) - boolean))) - -(defun comp-tests-define-type-spec-test (number x) - `(comp-deftest ,(intern (format "ret-type-spec-%d" number)) () - ,(format "Type specifier test number %d." number) - (let ((comp-ctxt (make-comp-cstr-ctxt))) - (comp-tests-check-ret-type-spec ',(car x) ',(cadr x))))) + 'foo + 3)) + (or (member foo) (integer 3 3))) + + ;; 8 + ((defun comp-tests-ret-type-spec-f (x) + (if (eq x 3) + x + 'foo)) + (or (member foo) (integer 3 3))) + + ;; 9 + ((defun comp-tests-ret-type-spec-f (x) + (if (eq 3 x) + x + 'foo)) + (or (member foo) (integer 3 3))) + + ;; 10 + ((defun comp-tests-ret-type-spec-f (x) + (if (= x 3) + x + 'foo)) + (or (member foo) (integer 3 3))) + + ;; 11 + ((defun comp-tests-ret-type-spec-f (x) + (if (= 3 x) + x + 'foo)) + (or (member foo) (integer 3 3))) + + ;; 12 + ((defun comp-tests-ret-type-spec-f (x) + (if (= x 3) + 'foo + x)) + (or (member foo) marker number)) + + ;; 13 + ((defun comp-tests-ret-type-spec-f (x y) + (if (= x y) + x + 'foo)) + (or (member foo) marker number)) + + ;; 14 + ((defun comp-tests-ret-type-spec-f (x) + (comp-hint-fixnum x)) + (integer ,most-negative-fixnum ,most-positive-fixnum)) + + ;; 15 + ((defun comp-tests-ret-type-spec-f (x) + (comp-hint-cons x)) + cons) + + ;; 16 + ((defun comp-tests-ret-type-spec-f (x) + (let (y) + (when x + (setf y 4)) + y)) + (or null (integer 4 4))) + + ;; 17 + ((defun comp-tests-ret-type-spec-f () + (let (x + (y 3)) + (setf x y) + y)) + (integer 3 3)) + + ;; 18 + ((defun comp-tests-ret-type-spec-f (x) + (let ((y 3)) + (when x + (setf y x)) + y)) + t) + + ;; 19 + ((defun comp-tests-ret-type-spec-f (x y) + (eq x y)) + boolean))) + + (defun comp-tests-define-type-spec-test (number x) + `(comp-deftest ,(intern (format "ret-type-spec-%d" number)) () + ,(format "Type specifier test number %d." number) + (let ((comp-ctxt (make-comp-cstr-ctxt))) + (comp-tests-check-ret-type-spec ',(car x) ',(cadr x)))))) (defmacro comp-tests-define-type-spec-tests () "Define all type specifier tests." commit e0f20da6ecd1fceabdce480dd878be293cfba027 Author: Andrea Corallo Date: Fri Dec 18 17:22:05 2020 +0100 Simplify correctly (or (integer 1 1) (not (integer 1 1))) as t * lisp/emacs-lisp/comp-cstr.el (comp-cstr-union-1-no-mem): Logic update. * test/lisp/emacs-lisp/comp-cstr-tests.el (comp-cstr-typespec-tests-alist): Add a test. diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el index a172203596..22d3958aed 100644 --- a/lisp/emacs-lisp/comp-cstr.el +++ b/lisp/emacs-lisp/comp-cstr.el @@ -474,12 +474,17 @@ DST is returned." (cl-nset-difference (valset neg) (valset pos))))) ;; Range propagation - (setf (range neg) - (when range - (comp-range-negation - (comp-range-union - (comp-range-negation (range neg)) - (range pos))))) + (when range + ;; Handle apart (or (integer 1 1) (not (integer 1 1))) + ;; like cases. + (if (and (range pos) (range neg) + (equal (range pos) (range neg))) + (give-up) + (setf (range neg) + (comp-range-negation + (comp-range-union + (comp-range-negation (range neg)) + (range pos)))))) (if (comp-cstr-empty-p neg) (setf (typeset dst) (typeset pos) diff --git a/test/lisp/emacs-lisp/comp-cstr-tests.el b/test/lisp/emacs-lisp/comp-cstr-tests.el index f7ea00e86f..b38573ca33 100644 --- a/test/lisp/emacs-lisp/comp-cstr-tests.el +++ b/test/lisp/emacs-lisp/comp-cstr-tests.el @@ -199,7 +199,9 @@ ;; 80 ((and (or marker number) (integer 0 0)) . (integer 0 0)) ;; 81 - ((and t (not t)) . nil)) + ((and t (not t)) . nil) + ;; 82 + ((or (integer 1 1) (not (integer 1 1))) . t)) "Alist type specifier -> expected type specifier.") (defmacro comp-cstr-synthesize-tests () commit 3540b1f167d63e1a38ec0719f909dcda60c77ad3 Author: Andrea Corallo Date: Thu Dec 17 17:31:22 2020 +0100 * Guarantee fwprop convergence and termination * lisp/emacs-lisp/comp.el (comp-emit-call-cstr): Have new-mvar as LHS *and* RHS when constraining in and to ensure monotonicity and fwprop convergence. (comp-fwprop): Raise a warning for debug reasons in case fwprop does not converge within 100 iterations. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 6f1ef26ac7..5d2f8d412f 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1982,9 +1982,11 @@ TARGET-BB-SYM is the symbol name of the target block." (defun comp-emit-call-cstr (mvar call-cell cstr) "Emit a constraint CSTR for MVAR after CALL-CELL." - (let ((next-cell (cdr call-cell)) - (new-cell `((assume ,(make-comp-mvar :slot (comp-mvar-slot mvar)) - (and ,mvar ,cstr))))) + (let* ((next-cell (cdr call-cell)) + (new-mvar (make-comp-mvar :slot (comp-mvar-slot mvar))) + ;; Have new-mvar as LHS *and* RHS to ensure monotonicity and + ;; fwprop convergence!! + (new-cell `((assume ,new-mvar (and ,new-mvar ,mvar ,cstr))))) (setf (cdr call-cell) new-cell (cdr new-cell) next-cell (comp-func-ssa-status comp-func) 'dirty))) @@ -2568,9 +2570,14 @@ Return t if something was changed." (let ((comp-func f)) (comp-fwprop-prologue) (cl-loop - for i from 1 + for i from 1 to 100 while (comp-fwprop*) - finally (comp-log (format "Propagation run %d times\n" i) 2)) + finally + (when (= i 100) + (display-warning + 'comp + (format "fwprop pass jammed into %s?" (comp-func-name f)))) + (comp-log (format "Propagation run %d times\n" i) 2)) (comp-log-func comp-func 3)))) (comp-ctxt-funcs-h comp-ctxt))) commit c70c08013f96438b640e07f884349d9436897252 Author: Andrea Corallo Date: Thu Dec 17 22:31:09 2020 +0100 * Allow for overlapping src and dst in cstr set operations * lisp/emacs-lisp/comp-cstr.el (comp-cstr-union-1-no-mem) (comp-cstr-union-1, comp-cstr-intersection-no-mem) (comp-cstr-intersection): Logic update. diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el index cd8f432412..a172203596 100644 --- a/lisp/emacs-lisp/comp-cstr.el +++ b/lisp/emacs-lisp/comp-cstr.el @@ -402,113 +402,114 @@ DST is returned." (mapcar #'comp-cstr-range srcs)))) dst) -(cl-defun comp-cstr-union-1-no-mem (range dst &rest srcs) +(cl-defun comp-cstr-union-1-no-mem (range &rest srcs) "Combine SRCS by union set operation setting the result in DST. Do range propagation when RANGE is non-nil. Non memoized version of `comp-cstr-union-1'. DST is returned." (with-comp-cstr-accessors - (cl-flet ((give-up () - (setf (typeset dst) '(t) - (valset dst) () - (range dst) () + (let ((dst (make-comp-cstr))) + (cl-flet ((give-up () + (setf (typeset dst) '(t) + (valset dst) () + (range dst) () + (neg dst) nil) + (cl-return-from comp-cstr-union-1-no-mem dst))) + + ;; Check first if we are in the simple case of all input non-negate + ;; or negated so we don't have to cons. + (when-let ((res (comp-cstrs-homogeneous srcs))) + (apply #'comp-cstr-union-homogeneous dst srcs) + (cl-return-from comp-cstr-union-1-no-mem dst)) + + ;; Some are negated and some are not + (cl-multiple-value-bind (positives negatives) (comp-split-pos-neg srcs) + (let* ((pos (apply #'comp-cstr-union-homogeneous + (make-comp-cstr) positives)) + ;; We'll always use neg as result as this is almost + ;; always necessary for describing open intervals + ;; resulting from negated constraints. + (neg (apply #'comp-cstr-union-homogeneous + (make-comp-cstr :neg t) negatives))) + ;; Type propagation. + (when (and (typeset pos) + ;; When every pos type is a subtype of some neg ones. + (cl-every (lambda (x) + (cl-some (lambda (y) + (comp-subtype-p x y)) + (append (typeset neg) + (when (range neg) + '(integer))))) + (typeset pos))) + ;; This is a conservative choice, ATM we can't represent such + ;; a disjoint set of types unless we decide to add a new slot + ;; into `comp-cstr' or adopt something like + ;; `intersection-type' `union-type' in SBCL. Keep it + ;; "simple" for now. + (give-up)) + + ;; Verify disjoint condition between positive types and + ;; negative types coming from values, in case give-up. + (let ((neg-value-types (nconc (mapcar #'type-of (valset neg)) + (when (range neg) + '(integer))))) + (when (cl-some (lambda (x) + (cl-some (lambda (y) + (and (not (eq y x)) + (comp-subtype-p y x))) + neg-value-types)) + (typeset pos)) + (give-up))) + + ;; Value propagation. + (cond + ((and (valset pos) (valset neg) + (equal (comp-union-valsets (valset pos) (valset neg)) + (valset pos))) + ;; Pos is a superset of neg. + (give-up)) + (t + ;; pos is a subset or eq to neg + (setf (valset neg) + (cl-nset-difference (valset neg) (valset pos))))) + + ;; Range propagation + (setf (range neg) + (when range + (comp-range-negation + (comp-range-union + (comp-range-negation (range neg)) + (range pos))))) + + (if (comp-cstr-empty-p neg) + (setf (typeset dst) (typeset pos) + (valset dst) (valset pos) + (range dst) (range pos) (neg dst) nil) - (cl-return-from comp-cstr-union-1-no-mem dst))) - - ;; Check first if we are in the simple case of all input non-negate - ;; or negated so we don't have to cons. - (when-let ((res (comp-cstrs-homogeneous srcs))) - (apply #'comp-cstr-union-homogeneous dst srcs) - (cl-return-from comp-cstr-union-1-no-mem dst)) - - ;; Some are negated and some are not - (cl-multiple-value-bind (positives negatives) (comp-split-pos-neg srcs) - (let* ((pos (apply #'comp-cstr-union-homogeneous - (make-comp-cstr) positives)) - ;; We'll always use neg as result as this is almost - ;; always necessary for describing open intervals - ;; resulting from negated constraints. - (neg (apply #'comp-cstr-union-homogeneous - (make-comp-cstr :neg t) negatives))) - ;; Type propagation. - (when (and (typeset pos) - ;; When every pos type is a subtype of some neg ones. - (cl-every (lambda (x) - (cl-some (lambda (y) - (comp-subtype-p x y)) - (append (typeset neg) - (when (range neg) - '(integer))))) - (typeset pos))) - ;; This is a conservative choice, ATM we can't represent such - ;; a disjoint set of types unless we decide to add a new slot - ;; into `comp-cstr' or adopt something like - ;; `intersection-type' `union-type' in SBCL. Keep it - ;; "simple" for now. - (give-up)) - - ;; Verify disjoint condition between positive types and - ;; negative types coming from values, in case give-up. - (let ((neg-value-types (nconc (mapcar #'type-of (valset neg)) - (when (range neg) - '(integer))))) - (when (cl-some (lambda (x) - (cl-some (lambda (y) - (and (not (eq y x)) - (comp-subtype-p y x))) - neg-value-types)) - (typeset pos)) - (give-up))) - - ;; Value propagation. - (cond - ((and (valset pos) (valset neg) - (equal (comp-union-valsets (valset pos) (valset neg)) - (valset pos))) - ;; Pos is a superset of neg. - (give-up)) - (t - ;; pos is a subset or eq to neg - (setf (valset neg) - (cl-nset-difference (valset neg) (valset pos))))) - - ;; Range propagation - (setf (range neg) - (when range - (comp-range-negation - (comp-range-union - (comp-range-negation (range neg)) - (range pos))))) - - (if (comp-cstr-empty-p neg) - (setf (typeset dst) (typeset pos) - (valset dst) (valset pos) - (range dst) (range pos) - (neg dst) nil) - (setf (typeset dst) (typeset neg) - (valset dst) (valset neg) - (range dst) (range neg) - (neg dst) (neg neg)))))) - dst)) + (setf (typeset dst) (typeset neg) + (valset dst) (valset neg) + (range dst) (range neg) + (neg dst) (neg neg)))))) + dst))) (defun comp-cstr-union-1 (range dst &rest srcs) "Combine SRCS by union set operation setting the result in DST. Do range propagation when RANGE is non-nil. DST is returned." - (let ((mem-h (if range - (comp-cstr-ctxt-union-1-mem-range comp-ctxt) - (comp-cstr-ctxt-union-1-mem-no-range comp-ctxt)))) - (with-comp-cstr-accessors - (if-let ((mem-res (gethash srcs mem-h))) - (progn - (setf (typeset dst) (typeset mem-res) - (valset dst) (valset mem-res) - (range dst) (range mem-res) - (neg dst) (neg mem-res)) - mem-res) - (let ((res (apply #'comp-cstr-union-1-no-mem range dst srcs))) - (puthash srcs (comp-cstr-copy res) mem-h) - res))))) + (with-comp-cstr-accessors + (let* ((mem-h (if range + (comp-cstr-ctxt-union-1-mem-range comp-ctxt) + (comp-cstr-ctxt-union-1-mem-no-range comp-ctxt))) + (res (or (gethash srcs mem-h) + (puthash + srcs + (apply #'comp-cstr-union-1-no-mem range srcs) + mem-h)))) + (setf (typeset dst) (typeset res) + (valset dst) (valset res) + (range dst) (range res) + (neg dst) (neg res)) + res))) (cl-defun comp-cstr-intersection-homogeneous (dst &rest srcs) "Combine SRCS by intersection set operation setting the result in DST. @@ -567,84 +568,83 @@ DST is returned." dst)) -(cl-defun comp-cstr-intersection-no-mem (dst &rest srcs) - "Combine SRCS by intersection set operation setting the result in DST. -Non memoized version of `comp-cstr-intersection-no-mem'. -DST is returned." - (with-comp-cstr-accessors - (cl-flet ((return-empty () +(cl-defun comp-cstr-intersection-no-mem (&rest srcs) + "Combine SRCS by intersection set operation. +Non memoized version of `comp-cstr-intersection-no-mem'." + (let ((dst (make-comp-cstr))) + (with-comp-cstr-accessors + (cl-flet ((return-empty () + (setf (typeset dst) () + (valset dst) () + (range dst) () + (neg dst) nil) + (cl-return-from comp-cstr-intersection-no-mem dst))) + (when-let ((res (comp-cstrs-homogeneous srcs))) + (if (eq res 'neg) + (apply #'comp-cstr-union-homogeneous dst srcs) + (apply #'comp-cstr-intersection-homogeneous dst srcs)) + (cl-return-from comp-cstr-intersection-no-mem dst)) + + ;; Some are negated and some are not + (cl-multiple-value-bind (positives negatives) (comp-split-pos-neg srcs) + (let* ((pos (apply #'comp-cstr-intersection-homogeneous + (make-comp-cstr) positives)) + (neg (apply #'comp-cstr-intersection-homogeneous + (make-comp-cstr) negatives))) + + ;; In case pos is not relevant return directly the content + ;; of neg. + (when (equal (typeset pos) '(t)) + (setf (typeset dst) (typeset neg) + (valset dst) (valset neg) + (range dst) (range neg) + (neg dst) t) + + ;; (not t) => nil + (when (and (null (valset dst)) + (null (range dst)) + (neg dst) + (equal '(t) (typeset dst))) (setf (typeset dst) () - (valset dst) () - (range dst) () - (neg dst) nil) - (cl-return-from comp-cstr-intersection-no-mem dst))) - (when-let ((res (comp-cstrs-homogeneous srcs))) - (if (eq res 'neg) - (apply #'comp-cstr-union-homogeneous dst srcs) - (apply #'comp-cstr-intersection-homogeneous dst srcs)) - (cl-return-from comp-cstr-intersection-no-mem dst)) - - ;; Some are negated and some are not - (cl-multiple-value-bind (positives negatives) (comp-split-pos-neg srcs) - (let* ((pos (apply #'comp-cstr-intersection-homogeneous - (make-comp-cstr) positives)) - (neg (apply #'comp-cstr-intersection-homogeneous - (make-comp-cstr) negatives))) - - ;; In case pos is not relevant return directly the content - ;; of neg. - (when (equal (typeset pos) '(t)) - (setf (typeset dst) (typeset neg) - (valset dst) (valset neg) - (range dst) (range neg) - (neg dst) t) - - ;; (not t) => nil - (when (and (null (valset dst)) - (null (range dst)) - (neg dst) - (equal '(t) (typeset dst))) - (setf (typeset dst) () - (neg dst) nil)) - - (cl-return-from comp-cstr-intersection-no-mem dst)) - - (when (cl-some - (lambda (ty) - (memq ty (typeset neg))) - (typeset pos)) - (return-empty)) - - ;; Some negated types are subtypes of some non-negated one. - ;; Transform the corresponding set of types from neg to pos. - (cl-loop - for neg-type in (typeset neg) - do (cl-loop - for pos-type in (copy-sequence (typeset pos)) - when (and (not (eq neg-type pos-type)) - (comp-subtype-p neg-type pos-type)) - do (cl-loop - with found - for (type . _) in (comp-supertypes neg-type) - when found - collect type into res - when (eq type pos-type) - do (setf (typeset pos) (cl-union (typeset pos) res)) - ;; (delq neg-type (typeset neg)) - (cl-return) - when (eq type neg-type) - do (setf found t)))) - - (setf (range pos) - (comp-range-intersection (range pos) - (comp-range-negation (range neg)))) - - ;; Return a non negated form. - (setf (typeset dst) (typeset pos) - (valset dst) (valset pos) - (range dst) (range pos) - (neg dst) nil))) - dst))) + (neg dst) nil)) + + (cl-return-from comp-cstr-intersection-no-mem dst)) + + (when (cl-some + (lambda (ty) + (memq ty (typeset neg))) + (typeset pos)) + (return-empty)) + + ;; Some negated types are subtypes of some non-negated one. + ;; Transform the corresponding set of types from neg to pos. + (cl-loop + for neg-type in (typeset neg) + do (cl-loop + for pos-type in (copy-sequence (typeset pos)) + when (and (not (eq neg-type pos-type)) + (comp-subtype-p neg-type pos-type)) + do (cl-loop + with found + for (type . _) in (comp-supertypes neg-type) + when found + collect type into res + when (eq type pos-type) + do (setf (typeset pos) (cl-union (typeset pos) res)) + (cl-return) + when (eq type neg-type) + do (setf found t)))) + + (setf (range pos) + (comp-range-intersection (range pos) + (comp-range-negation (range neg)))) + + ;; Return a non negated form. + (setf (typeset dst) (typeset pos) + (valset dst) (valset pos) + (range dst) (range pos) + (neg dst) nil))) + dst)))) ;;; Entry points. @@ -667,18 +667,18 @@ DST is returned." (defun comp-cstr-intersection (dst &rest srcs) "Combine SRCS by intersection set operation setting the result in DST. DST is returned." - (let ((mem-h (comp-cstr-ctxt-intersection-mem comp-ctxt))) - (with-comp-cstr-accessors - (if-let ((mem-res (gethash srcs mem-h))) - (progn - (setf (typeset dst) (typeset mem-res) - (valset dst) (valset mem-res) - (range dst) (range mem-res) - (neg dst) (neg mem-res)) - mem-res) - (let ((res (apply #'comp-cstr-intersection-no-mem dst srcs))) - (puthash srcs (comp-cstr-copy res) mem-h) - res))))) + (with-comp-cstr-accessors + (let* ((mem-h (comp-cstr-ctxt-intersection-mem comp-ctxt)) + (res (or (gethash srcs mem-h) + (puthash + srcs + (apply #'comp-cstr-intersection-no-mem srcs) + mem-h)))) + (setf (typeset dst) (typeset res) + (valset dst) (valset res) + (range dst) (range res) + (neg dst) (neg res)) + res))) (defun comp-cstr-intersection-make (&rest srcs) "Combine SRCS by intersection set operation and return a new constraint." commit 8e816b0ad574a279b12a4d6622c6f224b67083b8 Author: Andrea Corallo Date: Thu Dec 17 18:01:10 2020 +0100 Symplify type specifier (not t) as nil * lisp/emacs-lisp/comp-cstr.el (comp-cstr-intersection-no-mem): Add logic. * test/lisp/emacs-lisp/comp-cstr-tests.el (comp-cstr-typespec-tests-alist): Add two tests. diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el index 3f3f4f6145..cd8f432412 100644 --- a/lisp/emacs-lisp/comp-cstr.el +++ b/lisp/emacs-lisp/comp-cstr.el @@ -598,6 +598,15 @@ DST is returned." (valset dst) (valset neg) (range dst) (range neg) (neg dst) t) + + ;; (not t) => nil + (when (and (null (valset dst)) + (null (range dst)) + (neg dst) + (equal '(t) (typeset dst))) + (setf (typeset dst) () + (neg dst) nil)) + (cl-return-from comp-cstr-intersection-no-mem dst)) (when (cl-some diff --git a/test/lisp/emacs-lisp/comp-cstr-tests.el b/test/lisp/emacs-lisp/comp-cstr-tests.el index 03bf78968f..f7ea00e86f 100644 --- a/test/lisp/emacs-lisp/comp-cstr-tests.el +++ b/test/lisp/emacs-lisp/comp-cstr-tests.el @@ -195,7 +195,11 @@ ;; 77 ((and (or symbol string) (or number marker)) . nil) ;; 78 - ((and t t) . t)) + ((and t t) . t) + ;; 80 + ((and (or marker number) (integer 0 0)) . (integer 0 0)) + ;; 81 + ((and t (not t)) . nil)) "Alist type specifier -> expected type specifier.") (defmacro comp-cstr-synthesize-tests () commit 07b75deea9febd2cb6fd4d3467e909df341e96fb Author: Andrea Corallo Date: Tue Dec 15 23:53:29 2020 +0100 Enhance type inference constraining function arguments * lisp/emacs-lisp/comp.el: Add some commentary. (comp-cond-cstrs-target-mvar): Rename and update docstring. (comp-add-cond-cstrs): Update to use `comp-cond-cstrs-target-mvar'. (comp-emit-call-cstr, comp-lambda-list-gen, comp-add-call-cstr): New functions. (comp-add-cstrs): Call `comp-add-call-cstr'. * test/src/comp-tests.el (comp-tests-type-spec-tests): Update two type specifier tests. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index e8db2383c4..6f1ef26ac7 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1868,7 +1868,19 @@ into the C code forwarding the compilation unit." (comp-add-func-to-ctxt (comp-limplify-top-level t)))) -;;; conditional branches rewrite pass specific code. +;;; add-cstrs pass specific code. + +;; This pass is responsible for adding constraints, these are +;; generated from: +;; +;; - Conditional branches: each branch taken or non taken can be used +;; in the CFG to infer infomations on the tested variables. +;; +;; - Function calls: function calls to function assumed to be not +;; redefinable can be used to add constrains on the function +;; arguments. Ex: if we execute successfully (= x y) we know that +;; afterwards both x and y must satisfy the (or number marker) +;; type specifier. (defun comp-emit-assume (target rhs bb negated) "Emit an assume for mvar TARGET being RHS. @@ -1907,10 +1919,10 @@ The assume is emitted at the beginning of the block BB." (cl-return (puthash bb-symbol new-bb (comp-func-blocks comp-func))) finally (cl-assert nil))) -(defun comp-add-cond-cstrs-target-mvar (mvar exit-insn bb) - "Given MVAR search in BB what we'll use as assume target. -Keep on searching till EXIT-INSN is encountered. -Return the corresponding rhs mvar." +;; Cheap substitute to a copy propagation pass... +(defun comp-cond-cstrs-target-mvar (mvar exit-insn bb) + "Given MVAR search in BB the original mvar MVAR got assigned from. +Keep on searching till EXIT-INSN is encountered." (cl-flet ((targetp (x) ;; Ret t if x is an mvar and target the correct slot number. (and (comp-mvar-p x) @@ -1955,10 +1967,8 @@ TARGET-BB-SYM is the symbol name of the target block." (comment ,_comment-str) (cond-jump ,cond ,(pred comp-mvar-p) . ,blocks)) (cl-loop - with target-mvar1 = (comp-add-cond-cstrs-target-mvar op1 (car insns-seq) - b) - with target-mvar2 = (comp-add-cond-cstrs-target-mvar op2 (car insns-seq) - b) + with target-mvar1 = (comp-cond-cstrs-target-mvar op1 (car insns-seq) b) + with target-mvar2 = (comp-cond-cstrs-target-mvar op2 (car insns-seq) b) for branch-target-cell on blocks for branch-target = (car branch-target-cell) for assume-target = (comp-add-cond-cstrs-target-block b branch-target) @@ -1970,6 +1980,57 @@ TARGET-BB-SYM is the symbol name of the target block." do (comp-emit-assume target-mvar2 op1 assume-target negated) finally (cl-return-from in-the-basic-block))))))) +(defun comp-emit-call-cstr (mvar call-cell cstr) + "Emit a constraint CSTR for MVAR after CALL-CELL." + (let ((next-cell (cdr call-cell)) + (new-cell `((assume ,(make-comp-mvar :slot (comp-mvar-slot mvar)) + (and ,mvar ,cstr))))) + (setf (cdr call-cell) new-cell + (cdr new-cell) next-cell + (comp-func-ssa-status comp-func) 'dirty))) + +(defun comp-lambda-list-gen (lambda-list) + "Return a generator to iterate over LAMBDA-LIST." + (lambda () + (cl-case (car lambda-list) + (&optional + (setf lambda-list (cdr lambda-list)) + (prog1 + (car lambda-list) + (setf lambda-list (cdr lambda-list)))) + (&rest + (cadr lambda-list)) + (t + (prog1 + (car lambda-list) + (setf lambda-list (cdr lambda-list))))))) + +(defun comp-add-call-cstr () + "Add args assumptions for each function of which the type specifier is known." + (cl-loop + for bb being each hash-value of (comp-func-blocks comp-func) + do + (comp-loop-insn-in-block bb + (when-let ((match + (pcase insn + (`(set ,lhs (,(pred comp-call-op-p) ,f . ,args)) + (when-let ((cstr-f (gethash f comp-known-func-cstr-h))) + (cl-values cstr-f lhs args))) + (`(,(pred comp-call-op-p) ,f . ,args) + (when-let ((cstr-f (gethash f comp-known-func-cstr-h))) + (cl-values cstr-f nil args)))))) + (cl-multiple-value-bind (cstr-f lhs args) match + (cl-loop + for arg in args + for gen = (comp-lambda-list-gen (comp-cstr-f-args cstr-f)) + for cstr = (funcall gen) + for target = (comp-cond-cstrs-target-mvar arg insn bb) + when (and target + (or (null lhs) + (not (eql (comp-mvar-slot lhs) + (comp-mvar-slot target))))) + 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 @@ -1984,6 +2045,7 @@ blocks." (not (comp-func-has-non-local f))) (let ((comp-func f)) (comp-add-cond-cstrs) + (comp-add-call-cstr) (comp-log-func comp-func 3)))) (comp-ctxt-funcs-h comp-ctxt))) diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 4ea8dbbadb..a3e887bde9 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -872,14 +872,14 @@ Return a list of results." (if (= x 3) 'foo x)) - (or (member foo) (integer * 2) (integer 4 *))) + (or (member foo) marker number)) ;; 13 ((defun comp-tests-ret-type-spec-8-4-f (x y) (if (= x y) x 'foo)) - t) + (or (member foo) marker number)) ;; 14 ((defun comp-tests-ret-type-spec-9-1-f (x) commit 23791cf74da9c2e6369f2c15ef180ef2a8c21656 Author: Andrea Corallo Date: Tue Dec 15 17:45:53 2020 +0100 * Allow for modifying insn-cell inside `comp-loop-insn-in-block' * lisp/emacs-lisp/comp.el (comp-loop-insn-in-block): Update. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 8791759aaf..e8db2383c4 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -759,14 +759,15 @@ VERBOSITY is a number between 0 and 3." (defmacro comp-loop-insn-in-block (basic-block &rest body) "Loop over all insns in BASIC-BLOCK executing BODY. -Inside BODY `insn' can be used to read or set the current -instruction." +Inside BODY `insn' and `insn-cell'can be used to read or set the +current instruction or its cell." (declare (debug (form body)) (indent defun)) - (let ((sym-cell (gensym "cell-"))) - `(cl-symbol-macrolet ((insn (car ,sym-cell))) - (cl-loop for ,sym-cell on (comp-block-insns ,basic-block) - do ,@body)))) + `(cl-symbol-macrolet ((insn (car insn-cell))) + (let ((insn-cell (comp-block-insns ,basic-block))) + (while insn-cell + ,@body + (setf insn-cell (cdr insn-cell)))))) ;;; spill-lap pass specific code. commit 02551085c121905146fdb48079f300b3376c5a99 Author: Andrea Corallo Date: Tue Dec 15 16:57:23 2020 +0100 * Rename comp-cond-cstr into comp-add-cstrs * lisp/emacs-lisp/comp.el (comp-add-cond-cstrs-target-mvar) (comp-add-cond-cstrs, comp-add-cstrs): Rename comp-cond-cstr -> comp-add-cstrs. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 750c298a02..8791759aaf 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -164,7 +164,7 @@ Can be one of: 'd-default', 'd-impure' or 'd-ephemeral'. See `comp-ctxt'.") comp-fwprop comp-call-optim comp-ipa-pure - comp-cond-cstr + comp-add-cstrs comp-fwprop comp-dead-code comp-tco @@ -1884,24 +1884,6 @@ The assume is emitted at the beginning of the block BB." (comp-block-insns bb))) (setf (comp-func-ssa-status comp-func) 'dirty))) -(defun comp-cond-cstr-target-mvar (mvar exit-insn bb) - "Given MVAR search in BB what we'll use as assume target. -Keep on searching till EXIT-INSN is encountered. -Return the corresponding rhs mvar." - (cl-flet ((targetp (x) - ;; Ret t if x is an mvar and target the correct slot number. - (and (comp-mvar-p x) - (eql (comp-mvar-slot mvar) (comp-mvar-slot x))))) - (cl-loop - with res = nil - for insn in (comp-block-insns bb) - when (eq insn exit-insn) - do (cl-return (and (comp-mvar-p res) res)) - do (pcase insn - (`(,(pred comp-assign-op-p) ,(pred targetp) ,rhs) - (setf res rhs))) - finally (cl-assert nil)))) - (defun comp-add-new-block-beetween (bb-symbol bb-a bb-b) "Create a new basic-block named BB-SYMBOL and add it between BB-A and BB-B." (cl-loop @@ -1924,7 +1906,25 @@ Return the corresponding rhs mvar." (cl-return (puthash bb-symbol new-bb (comp-func-blocks comp-func))) finally (cl-assert nil))) -(defun comp-cond-cstr-target-block (curr-bb target-bb-sym) +(defun comp-add-cond-cstrs-target-mvar (mvar exit-insn bb) + "Given MVAR search in BB what we'll use as assume target. +Keep on searching till EXIT-INSN is encountered. +Return the corresponding rhs mvar." + (cl-flet ((targetp (x) + ;; Ret t if x is an mvar and target the correct slot number. + (and (comp-mvar-p x) + (eql (comp-mvar-slot mvar) (comp-mvar-slot x))))) + (cl-loop + with res = nil + for insn in (comp-block-insns bb) + when (eq insn exit-insn) + do (cl-return (and (comp-mvar-p res) res)) + do (pcase insn + (`(,(pred comp-assign-op-p) ,(pred targetp) ,rhs) + (setf res rhs))) + finally (cl-assert nil)))) + +(defun comp-add-cond-cstrs-target-block (curr-bb target-bb-sym) "Return the appropriate basic block to add constraint assumptions into. CURR-BB is the current basic block. TARGET-BB-SYM is the symbol name of the target block." @@ -1938,8 +1938,8 @@ TARGET-BB-SYM is the symbol name of the target block." "_cstrs")) curr-bb target-bb)))) -(defun comp-cond-cstr-func () - "`comp-cond-cstr' worker function for each selected function." +(defun comp-add-cond-cstrs () + "`comp-add-cstrs' worker function for each selected function." (cl-loop for b being each hash-value of (comp-func-blocks comp-func) do @@ -1954,11 +1954,13 @@ TARGET-BB-SYM is the symbol name of the target block." (comment ,_comment-str) (cond-jump ,cond ,(pred comp-mvar-p) . ,blocks)) (cl-loop - with target-mvar1 = (comp-cond-cstr-target-mvar op1 (car insns-seq) b) - with target-mvar2 = (comp-cond-cstr-target-mvar op2 (car insns-seq) b) + with target-mvar1 = (comp-add-cond-cstrs-target-mvar op1 (car insns-seq) + b) + with target-mvar2 = (comp-add-cond-cstrs-target-mvar op2 (car insns-seq) + b) for branch-target-cell on blocks for branch-target = (car branch-target-cell) - for assume-target = (comp-cond-cstr-target-block b branch-target) + for assume-target = (comp-add-cond-cstrs-target-block b branch-target) for negated in '(nil t) do (setf (car branch-target-cell) (comp-block-name assume-target)) when target-mvar1 @@ -1967,7 +1969,7 @@ TARGET-BB-SYM is the symbol name of the target block." do (comp-emit-assume target-mvar2 op1 assume-target negated) finally (cl-return-from in-the-basic-block))))))) -(defun comp-cond-cstr (_) +(defun comp-add-cstrs (_) "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 @@ -1980,7 +1982,7 @@ blocks." (comp-func-l-p f) (not (comp-func-has-non-local f))) (let ((comp-func f)) - (comp-cond-cstr-func) + (comp-add-cond-cstrs) (comp-log-func comp-func 3)))) (comp-ctxt-funcs-h comp-ctxt))) commit d072ee9d3471772dffc42cd3e33b677c1cfb8965 Author: Andrea Corallo Date: Wed Dec 16 18:37:39 2020 +0100 * Two minors in comp.el * lisp/emacs-lisp/comp.el (comp-known-func-cstr-h) (comp-ret-type-spec): Style. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index a75ca312d2..750c298a02 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -275,7 +275,7 @@ Useful to hook into pass checkers.") for (f type-spec) in comp-known-type-specifiers for cstr = (comp-type-spec-to-cstr type-spec) do (puthash f cstr h) - finally (cl-return h)) + finally return h) "Hash table function -> `comp-constraint'") (defconst comp-symbol-values-optimizable '(most-positive-fixnum @@ -2761,7 +2761,7 @@ Set it into the `ret-type-specifier' slot." do (pcase insn (`(return ,mvar) (push mvar res)))) - finally (cl-return res))))) + finally return res)))) (setf (comp-func-ret-type-specifier func) (comp-cstr-to-type-spec res-mvar)))) commit 7074988d13353c544f0a870a8ff3a8deb7b0b8f6 Author: Andrea Corallo Date: Mon Dec 21 18:41:13 2020 +0100 * Add a type specifier test to comp-cstr-tests.el * test/lisp/emacs-lisp/comp-cstr-tests.el (comp-cstr-typespec-tests-alist): Add a test. diff --git a/test/lisp/emacs-lisp/comp-cstr-tests.el b/test/lisp/emacs-lisp/comp-cstr-tests.el index 70c446e9be..03bf78968f 100644 --- a/test/lisp/emacs-lisp/comp-cstr-tests.el +++ b/test/lisp/emacs-lisp/comp-cstr-tests.el @@ -193,7 +193,9 @@ ;; 76 ((and symbol (or number marker)) . nil) ;; 77 - ((and (or symbol string) (or number marker)) . nil)) + ((and (or symbol string) (or number marker)) . nil) + ;; 78 + ((and t t) . t)) "Alist type specifier -> expected type specifier.") (defmacro comp-cstr-synthesize-tests () commit 34c1d75a317778df1c09f29f10af207d0f36ad13 Author: Andrea Corallo Date: Mon Dec 21 18:39:34 2020 +0100 * Enumerate and split type specifier tests in comp-tests.el to ease debug * test/src/comp-tests.el (comp-tests-type-spec-tests): Enumerate. (comp-tests-define-type-spec-test): New function. (comp-tests-define-type-spec-tests): New macro to expand tests. diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 68201deffe..4ea8dbbadb 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -790,18 +790,23 @@ Return a list of results." (native-compile (cadr func-form)))) (defconst comp-tests-type-spec-tests - `(((defun comp-tests-ret-type-spec-f (x) + `( + ;; 1 + ((defun comp-tests-ret-type-spec-f (x) x) t) + ;; 2 ((defun comp-tests-ret-type-spec-f () 1) (integer 1 1)) + ;; 3 ((defun comp-tests-ret-type-spec-f (x) (if x 1 3)) (or (integer 1 1) (integer 3 3))) + ;; 4 ((defun comp-tests-ret-type-spec-f (x) (let (y) (if x @@ -810,6 +815,7 @@ Return a list of results." y)) (integer 1 2)) + ;; 5 ((defun comp-tests-ret-type-spec-f (x) (let (y) (if x @@ -818,77 +824,90 @@ Return a list of results." y)) (or (integer 1 1) (integer 3 3))) + + ;; 6 ((defun comp-tests-ret-type-spec-f (x) (if x (list x) 3)) (or cons (integer 3 3))) + ;; 7 ((defun comp-tests-ret-type-spec-f (x) (if x 'foo 3)) (or (member foo) (integer 3 3))) + ;; 8 ((defun comp-tests-ret-type-spec-f (x) (if (eq x 3) x 'foo)) (or (member foo) (integer 3 3))) + ;; 9 ((defun comp-tests-ret-type-spec-f (x) (if (eq 3 x) x 'foo)) (or (member foo) (integer 3 3))) + ;; 10 ((defun comp-tests-ret-type-spec-f (x) (if (= x 3) x 'foo)) (or (member foo) (integer 3 3))) + ;; 11 ((defun comp-tests-ret-type-spec-f (x) (if (= 3 x) x 'foo)) (or (member foo) (integer 3 3))) - ;; FIXME would be nice to have (or number (member foo)) + ;; 12 ((defun comp-tests-ret-type-spec-8-3-f (x) (if (= x 3) 'foo x)) - t) + (or (member foo) (integer * 2) (integer 4 *))) + ;; 13 ((defun comp-tests-ret-type-spec-8-4-f (x y) (if (= x y) x 'foo)) - (or (member foo) number)) + t) + ;; 14 ((defun comp-tests-ret-type-spec-9-1-f (x) (comp-hint-fixnum x)) (integer ,most-negative-fixnum ,most-positive-fixnum)) + ;; 15 ((defun comp-tests-ret-type-spec-f (x) (comp-hint-cons x)) cons) + ;; 16 ((defun comp-tests-ret-type-spec-f (x) - (let (y) - (when x - (setf y 4)) - y)) + (let (y) + (when x + (setf y 4)) + y)) (or null (integer 4 4))) + ;; 17 ((defun comp-tests-ret-type-spec-f () - (let (x - (y 3)) - (setf x y) - y)) + (let (x + (y 3)) + (setf x y) + y)) (integer 3 3)) + ;; 18 ((defun comp-tests-ret-type-spec-f (x) (let ((y 3)) (when x @@ -896,15 +915,26 @@ Return a list of results." y)) t) + ;; 19 ((defun comp-tests-ret-type-spec-f (x y) (eq x y)) boolean))) -(comp-deftest ret-type-spec () - "Some derived return type specifier tests." - (cl-loop with comp-ctxt = (make-comp-cstr-ctxt) - for (func-form type-spec) in comp-tests-type-spec-tests - do (comp-tests-check-ret-type-spec func-form type-spec))) +(defun comp-tests-define-type-spec-test (number x) + `(comp-deftest ,(intern (format "ret-type-spec-%d" number)) () + ,(format "Type specifier test number %d." number) + (let ((comp-ctxt (make-comp-cstr-ctxt))) + (comp-tests-check-ret-type-spec ',(car x) ',(cadr x))))) + +(defmacro comp-tests-define-type-spec-tests () + "Define all type specifier tests." + `(progn + ,@(cl-loop + for test in comp-tests-type-spec-tests + for n from 1 + collect (comp-tests-define-type-spec-test n test)))) + +(comp-tests-define-type-spec-tests) (defun comp-tests-pure-checker-1 (_) "Check that inside `comp-tests-pure-caller-f' `comp-tests-pure-callee-f' is commit 48d43f579e3d2f7e1423f315d537b51de51ea6a4 Author: Andrea Corallo Date: Wed Dec 16 18:41:18 2020 +0100 * Improve constraint simplification logic in comp-cstr.el * lisp/emacs-lisp/comp-cstr.el (with-comp-cstr-accessors): Simplify. (comp-cstr-empty-p): New Funchion. (comp-split-pos-neg): Minor. (comp-normalize-typeset): Logic update. (comp-union-typesets): Minor. (comp-intersect-two-typesets): New functio. (comp-intersect-typesets): Logic update. (comp-range-union, comp-range-intersection): Minor. (comp-cstr-union-homogeneous, comp-cstr-union-1-no-mem) (comp-cstr-intersection-homogeneous) (comp-cstr-intersection-no-mem, comp-cstr-negation) (comp-type-spec-to-cstr, comp-cstr-to-type-spec): Logic update. * lisp/emacs-lisp/comp-cstr.el (with-comp-cstr-accessors): Simplify. diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el index 6bacd24176..3f3f4f6145 100644 --- a/lisp/emacs-lisp/comp-cstr.el +++ b/lisp/emacs-lisp/comp-cstr.el @@ -100,14 +100,14 @@ Integer values are handled in the `range' slot.") "Define some quick accessor to reduce code vergosity in BODY." (declare (debug (form body)) (indent defun)) - `(cl-macrolet ((typeset (&rest x) - `(comp-cstr-typeset ,@x)) - (valset (&rest x) - `(comp-cstr-valset ,@x)) - (range (&rest x) - `(comp-cstr-range ,@x)) - (neg (&rest x) - `(comp-cstr-neg ,@x))) + `(cl-macrolet ((typeset (x) + `(comp-cstr-typeset ,x)) + (valset (x) + `(comp-cstr-valset ,x)) + (range (x) + `(comp-cstr-range ,x)) + (neg (x) + `(comp-cstr-neg ,x))) ,@body)) (defun comp-cstr-copy (cstr) @@ -118,6 +118,13 @@ Integer values are handled in the `range' slot.") :range (copy-tree (range cstr)) :neg (copy-tree (neg cstr))))) +(defsubst comp-cstr-empty-p (cstr) + "Return t if CSTR is equivalent to the `nil' type specifier or nil otherwise." + (with-comp-cstr-accessors + (and (null (typeset cstr)) + (null (valset cstr)) + (null (range cstr))))) + (defun comp-cstrs-homogeneous (cstrs) "Check if constraints CSTRS are all homogeneously negated or non-negated. Return `pos' if they are all positive, `neg' if they are all @@ -142,7 +149,7 @@ Return them as multiple value." collect cstr into negatives else collect cstr into positives - finally (cl-return (cl-values positives negatives)))) + finally return (cl-values positives negatives))) ;;; Value handling. @@ -168,9 +175,10 @@ Return them as multiple value." (defun comp-normalize-typeset (typeset) "Sort TYPESET and return it." - (cl-sort typeset (lambda (x y) - (string-lessp (symbol-name x) - (symbol-name y))))) + (cl-sort (cl-remove-duplicates typeset) + (lambda (x y) + (string-lessp (symbol-name x) + (symbol-name y))))) (defun comp-supertypes (type) "Return a list of pairs (supertype . hierarchy-level) for TYPE." @@ -224,22 +232,30 @@ Return them as multiple value." do (setf last x) finally (when last (push last res))) - finally (cl-return (comp-normalize-typeset - (cl-remove-duplicates res)))) + finally return (comp-normalize-typeset res)) (comp-cstr-ctxt-union-typesets-mem comp-ctxt)))) +(defun comp-intersect-two-typesets (t1 t2) + "Intersect typesets T1 and T2." + (with-comp-cstr-accessors + (cl-loop + for types in (list t1 t2) + for other-types in (list t2 t1) + append + (cl-loop + for type in types + when (cl-some (lambda (x) + (comp-subtype-p type x)) + other-types) + collect type)))) + (defun comp-intersect-typesets (&rest typesets) "Intersect types present into TYPESETS." - (when-let ((ty (apply #'append typesets))) - (if (> (length ty) 1) - (cl-reduce - (lambda (x y) - (let ((st (comp-common-supertype-2 x y))) - (cond - ((eq st x) (list y)) - ((eq st y) (list x))))) - ty) - (comp-normalize-typeset ty)))) + (unless (cl-some #'null typesets) + (if (= (length typesets) 1) + (car typesets) + (comp-normalize-typeset + (cl-reduce #'comp-intersect-two-typesets typesets))))) ;;; Integer range handling @@ -289,7 +305,7 @@ Return them as multiple value." (when (= nest 1) (push `(,(comp-range-1+ low) . ,i) res)) (cl-decf nest) - finally (cl-return (reverse res)))) + finally return (reverse res))) (defun comp-range-intersection (&rest ranges) "Combine integer intervals RANGES by intersecting." @@ -321,7 +337,7 @@ Return them as multiple value." (push `(,low . ,i) res)) (cl-decf nest) - finally (cl-return (reverse res)))) + finally return (reverse res))) (defun comp-range-negation (range) "Negate range RANGE." @@ -373,7 +389,11 @@ All SRCS constraints must be homogeneously negated or non-negated. DST is returned." (apply #'comp-cstr-union-homogeneous-no-range dst srcs) ;; Range propagation. - (setf (comp-cstr-range dst) + (setf (comp-cstr-neg dst) + (when srcs + (comp-cstr-neg (car srcs))) + + (comp-cstr-range dst) (when (cl-notany (lambda (x) (comp-subtype-p 'integer x)) (comp-cstr-typeset dst)) @@ -399,25 +419,26 @@ DST is returned." ;; or negated so we don't have to cons. (when-let ((res (comp-cstrs-homogeneous srcs))) (apply #'comp-cstr-union-homogeneous dst srcs) - (setf (neg dst) (eq res 'neg)) (cl-return-from comp-cstr-union-1-no-mem dst)) ;; Some are negated and some are not (cl-multiple-value-bind (positives negatives) (comp-split-pos-neg srcs) (let* ((pos (apply #'comp-cstr-union-homogeneous (make-comp-cstr) positives)) - ;; We use neg as result as *most* of times this will be - ;; negated. + ;; We'll always use neg as result as this is almost + ;; always necessary for describing open intervals + ;; resulting from negated constraints. (neg (apply #'comp-cstr-union-homogeneous (make-comp-cstr :neg t) negatives))) ;; Type propagation. (when (and (typeset pos) - ;; When every pos type is not a subtype of some neg ones. + ;; When every pos type is a subtype of some neg ones. (cl-every (lambda (x) (cl-some (lambda (y) - (not (and (not (eq x y)) - (comp-subtype-p x y)))) - (typeset neg))) + (comp-subtype-p x y)) + (append (typeset neg) + (when (range neg) + '(integer))))) (typeset pos))) ;; This is a conservative choice, ATM we can't represent such ;; a disjoint set of types unless we decide to add a new slot @@ -452,30 +473,14 @@ DST is returned." (cl-nset-difference (valset neg) (valset pos))))) ;; Range propagation - (if (and range - (or (range pos) - (range neg))) - (if (or (valset neg) (typeset neg)) - (setf (range neg) - (if (memq 'integer (typeset neg)) - (comp-range-negation (range pos)) - (comp-range-negation - (comp-range-union (range pos) - (comp-range-negation (range neg)))))) - ;; When possibile do not return a negated cstr. - (setf (typeset dst) (typeset pos) - (valset dst) (valset pos) - (range dst) (unless (memq 'integer (typeset dst)) - (comp-range-union - (comp-range-negation (range neg)) - (range pos))) - (neg dst) nil) - (cl-return-from comp-cstr-union-1-no-mem dst)) - (setf (range neg) ())) - - (if (and (null (typeset neg)) - (null (valset neg)) - (null (range neg))) + (setf (range neg) + (when range + (comp-range-negation + (comp-range-union + (comp-range-negation (range neg)) + (range pos))))) + + (if (comp-cstr-empty-p neg) (setf (typeset dst) (typeset pos) (valset dst) (valset pos) (range dst) (range pos) @@ -510,49 +515,57 @@ DST is returned." All SRCS constraints must be homogeneously negated or non-negated. DST is returned." - ;; Value propagation. - (setf (comp-cstr-valset dst) - ;; TODO sort. - (let ((values (cl-loop for src in srcs - for v = (comp-cstr-valset src) - when v - collect v))) - (when values - (cl-reduce (lambda (x y) - (cl-intersection x y :test #'equal)) - values)))) + (with-comp-cstr-accessors + (when (cl-some #'comp-cstr-empty-p srcs) + (setf (valset dst) nil + (range dst) nil + (typeset dst) nil) + (cl-return-from comp-cstr-intersection-homogeneous dst)) - ;; Range propagation. - (when (cl-some #'identity (mapcar #'comp-cstr-range srcs)) - (if (comp-cstr-valset dst) - (progn - (setf (comp-cstr-valset dst) nil - (comp-cstr-range dst) nil - (comp-cstr-typeset dst) nil) - (cl-return-from comp-cstr-intersection-homogeneous dst)) - ;; TODO memoize? - (setf (comp-cstr-range dst) - (apply #'comp-range-intersection - (mapcar #'comp-cstr-range srcs))))) + (setf (neg dst) (when srcs + (neg (car srcs)))) - ;; Type propagation. - (setf (comp-cstr-typeset dst) - (if (or (comp-cstr-range dst) (comp-cstr-valset dst)) - (cl-loop - with type-val = (cl-remove-duplicates - (append (mapcar #'type-of - (comp-cstr-valset dst)) - (when (comp-cstr-range dst) - '(integer)))) - for type in (apply #'comp-intersect-typesets - (mapcar #'comp-cstr-typeset srcs)) - when (and type (not (member type type-val))) - do (setf (comp-cstr-valset dst) nil - (comp-cstr-range dst) nil) - (cl-return nil)) + ;; Type propagation. + (setf (typeset dst) (apply #'comp-intersect-typesets - (mapcar #'comp-cstr-typeset srcs)))) - dst) + (mapcar #'comp-cstr-typeset srcs))) + + ;; Value propagation. + (setf (valset dst) + (comp-normalize-valset + (cl-loop + for src in srcs + append + (cl-loop + for val in (valset src) + ;; If (member value) is subtypep of all other sources then + ;; is good to be colleted. + when (cl-every (lambda (s) + (or (memq val (valset s)) + (cl-some (lambda (type) + (cl-typep val type)) + (typeset s)))) + (remq src srcs)) + collect val)))) + + ;; Range propagation. + (setf (range dst) + ;; Do range propagation only if the destination typeset + ;; doesn't cover it already. + (unless (cl-some (lambda (type) + (comp-subtype-p 'integer type)) + (typeset dst)) + (apply #'comp-range-intersection + (cl-loop + for src in srcs + ;; Collect effective ranges. + collect (or (range src) + (when (cl-some (lambda (s) + (comp-subtype-p 'integer s)) + (typeset src)) + '((- . +)))))))) + + dst)) (cl-defun comp-cstr-intersection-no-mem (dst &rest srcs) "Combine SRCS by intersection set operation setting the result in DST. @@ -566,8 +579,9 @@ DST is returned." (neg dst) nil) (cl-return-from comp-cstr-intersection-no-mem dst))) (when-let ((res (comp-cstrs-homogeneous srcs))) - (apply #'comp-cstr-intersection-homogeneous dst srcs) - (setf (neg dst) (eq res 'neg)) + (if (eq res 'neg) + (apply #'comp-cstr-union-homogeneous dst srcs) + (apply #'comp-cstr-intersection-homogeneous dst srcs)) (cl-return-from comp-cstr-intersection-no-mem dst)) ;; Some are negated and some are not @@ -575,7 +589,7 @@ DST is returned." (let* ((pos (apply #'comp-cstr-intersection-homogeneous (make-comp-cstr) positives)) (neg (apply #'comp-cstr-intersection-homogeneous - (make-comp-cstr :neg t) negatives))) + (make-comp-cstr) negatives))) ;; In case pos is not relevant return directly the content ;; of neg. @@ -613,12 +627,8 @@ DST is returned." do (setf found t)))) (setf (range pos) - (if (memq 'integer (typeset pos)) - (progn - (setf (typeset pos) (delq 'integer (typeset pos))) - (comp-range-negation (range neg))) - (comp-range-intersection (range pos) - (comp-range-negation (range neg))))) + (comp-range-intersection (range pos) + (comp-range-negation (range neg)))) ;; Return a non negated form. (setf (typeset dst) (typeset pos) @@ -668,11 +678,12 @@ DST is returned." (defun comp-cstr-negation (dst src) "Negate SRC setting the result in DST. DST is returned." - (setf (comp-cstr-typeset dst) (comp-cstr-typeset src) - (comp-cstr-valset dst) (comp-cstr-valset src) - (comp-cstr-range dst) (comp-cstr-range src) - (comp-cstr-neg dst) (not (comp-cstr-neg src))) - dst) + (with-comp-cstr-accessors + (setf (typeset dst) (typeset src) + (valset dst) (valset src) + (range dst) (range src) + (neg dst) (not (neg src))) + dst)) (defun comp-cstr-negation-make (src) "Negate SRC and return a new constraint." @@ -686,10 +697,14 @@ FN non-nil indicates we are parsing a function lambda list." (if fn x (error "Invalid `%s` in type specifier" x))) + ('nil + (make-comp-cstr :typeset ())) ('fixnum (comp-irange-to-cstr `(,most-negative-fixnum . ,most-positive-fixnum))) ('boolean (comp-type-spec-to-cstr '(member t nil))) + ('integer + (comp-irange-to-cstr '(- . +))) ('null (comp-value-to-cstr nil)) ((pred atom) (comp-type-to-cstr type-spec)) @@ -742,7 +757,10 @@ FN non-nil indicates we are parsing a function lambda list." (setf range (cl-loop for (l . h) in range for low = (if (integerp l) l '*) for high = (if (integerp h) h '*) - collect `(integer ,low , high)) + if (and (eq low '*) (eq high '*)) + collect 'integer + else + collect `(integer ,low , high)) valset (cl-remove-duplicates valset)) ;; Form the final type specifier. commit a0c0daf7a1059fac432f9507cbd198682d057ee5 Author: Andrea Corallo Date: Wed Dec 16 18:40:58 2020 +0100 * Fix a number of type specifier simplification tests * test/lisp/emacs-lisp/comp-cstr-tests.el (comp-cstr-typespec-tests-alist): Fix a number of tests. diff --git a/test/lisp/emacs-lisp/comp-cstr-tests.el b/test/lisp/emacs-lisp/comp-cstr-tests.el index bd141e13ad..70c446e9be 100644 --- a/test/lisp/emacs-lisp/comp-cstr-tests.el +++ b/test/lisp/emacs-lisp/comp-cstr-tests.el @@ -103,9 +103,9 @@ ;; 31 ((and (member 1 2) (member 3 2)) . (member 2)) ;; 32 - ((and number (integer 1 2)) . number) + ((and number (integer 1 2)) . (integer 1 2)) ;; 33 - ((and integer (integer 1 2)) . integer) + ((and integer (integer 1 2)) . (integer 1 2)) ;; 34 ((and (integer -1 0) (integer 3 5)) . nil) ;; 35 @@ -122,18 +122,18 @@ ((or (member foo) (not (member foo bar))) . (not (member bar))) ;; 41 ((or (member foo bar) (not (member foo))) . t) - ;; 42 Intentionally conservative, see `comp-cstr-union-1-no-mem'. - ((or symbol (not sequence)) . t) + ;; 42 + ((or symbol (not sequence)) . (not sequence)) ;; 43 ((or symbol (not symbol)) . t) - ;; 44 Conservative. - ((or symbol (not sequence)) . t) - ;; 45 - ((or vector (not sequence)) . (not sequence)) + ;; 44 + ((or symbol (not sequence)) . (not sequence)) + ;; 45 Conservative. + ((or vector (not sequence)) . t) ;; 46 - ((or (integer 1 10) (not (integer * 5))) . (integer 1 *)) + ((or (integer 1 10) (not (integer * 5))) . (not (integer * 0))) ;; 47 - ((or symbol (integer 1 10) (not (integer * 5))) . (or symbol (integer 1 *))) + ((or symbol (integer 1 10) (not (integer * 5))) . (not (integer * 0))) ;; 48 ((or (not symbol) (integer 1 10) (not (integer * 5))) . (not (or symbol (integer * 0)))) ;; 49 @@ -149,7 +149,7 @@ ;; 54 ((or (not (integer 1 2)) (not integer)) . (not integer)) ;; 55 - ((or (integer 1 2) (not integer)) . (not (or integer (integer * 0) (integer 3 *)))) + ((or (integer 1 2) (not integer)) . (not (or (integer * 0) (integer 3 *)))) ;; 56 ((or number (not (integer 1 2))) . t) ;; 57 @@ -177,7 +177,23 @@ ;; 68 ((and integer (not (integer 3 4))) . (or (integer * 2) (integer 5 *))) ;; 69 - ((and (integer 0 20) (not (integer 5 10))) . (or (integer 0 4) (integer 11 20)))) + ((and (integer 0 20) (not (integer 5 10))) . (or (integer 0 4) (integer 11 20))) + ;; 70 + ((and (not (member a)) (not (member b))) . (not (member b a))) + ;; 71 + ((and (not boolean) (not (member b))) . (not (or (member b) boolean))) + ;; 72 + ((and t (integer 1 1)) . (integer 1 1)) + ;; 73 + ((not (integer -1 5)) . (not (integer -1 5))) + ;; 74 + ((and boolean (or number marker)) . nil) + ;; 75 + ((and atom (or number marker)) . (or marker number)) + ;; 76 + ((and symbol (or number marker)) . nil) + ;; 77 + ((and (or symbol string) (or number marker)) . nil)) "Alist type specifier -> expected type specifier.") (defmacro comp-cstr-synthesize-tests () commit bad18f509d87fed8595761c0fabb65804ffcba52 Author: Andrea Corallo Date: Sun Dec 13 12:19:30 2020 +0100 * Improve comp-fwprop pass Wire-up comp-cstr.el routines in fwprop and constraint mvars also on the else side of branches. * lisp/emacs-lisp/comp.el (comp-emit-assume) (comp-cond-cstr-target-mvar, comp-cond-cstr-func) (comp-fwprop-insn): Logic update. (comp-mvar-value-vld-p, comp-mvar-propagate, comp-fwprop-call): Handle neg slot. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 24955c6a23..a75ca312d2 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -520,7 +520,8 @@ CFG is mutated by a pass.") (defun comp-mvar-value-vld-p (mvar) "Return t if one single value can be extracted by the MVAR constrains." - (when (null (comp-mvar-typeset mvar)) + (when (and (null (comp-mvar-typeset mvar)) + (null (comp-mvar-neg mvar))) (let* ((v (comp-mvar-valset mvar)) (r (comp-mvar-range mvar)) (valset-len (length v)) @@ -1868,26 +1869,34 @@ into the C code forwarding the compilation unit." ;;; conditional branches rewrite pass specific code. -(defun comp-emit-assume (target-slot rhs bb kind) - "Emit an assume of kind KIND for TARGET-SLOT being RHS. +(defun comp-emit-assume (target rhs bb negated) + "Emit an assume for mvar TARGET being RHS. +When NEGATED is non-nil the assumption is negated. The assume is emitted at the beginning of the block BB." - (push `(assume ,(make-comp-mvar :slot target-slot) ,rhs ,kind) - (comp-block-insns bb)) - (setf (comp-func-ssa-status comp-func) 'dirty)) - -(defun comp-cond-cstr-target-slot (slot-num exit-insn bb) - "Search for the last assignment of SLOT-NUM in BB. + (let ((target-slot (comp-mvar-slot target)) + (tmp-mvar (if negated + (make-comp-mvar :slot (comp-mvar-slot rhs)) + rhs))) + (push `(assume ,(make-comp-mvar :slot target-slot) (and ,target ,tmp-mvar)) + (comp-block-insns bb)) + (if negated + (push `(assume ,tmp-mvar (not ,rhs)) + (comp-block-insns bb))) + (setf (comp-func-ssa-status comp-func) 'dirty))) + +(defun comp-cond-cstr-target-mvar (mvar exit-insn bb) + "Given MVAR search in BB what we'll use as assume target. Keep on searching till EXIT-INSN is encountered. -Return the corresponding rhs slot number." +Return the corresponding rhs mvar." (cl-flet ((targetp (x) ;; Ret t if x is an mvar and target the correct slot number. (and (comp-mvar-p x) - (eql slot-num (comp-mvar-slot x))))) + (eql (comp-mvar-slot mvar) (comp-mvar-slot x))))) (cl-loop with res = nil for insn in (comp-block-insns bb) when (eq insn exit-insn) - do (cl-return (and (comp-mvar-p res) (comp-mvar-slot res))) + do (cl-return (and (comp-mvar-p res) res)) do (pcase insn (`(,(pred comp-assign-op-p) ,(pred targetp) ,rhs) (setf res rhs))) @@ -1941,19 +1950,22 @@ TARGET-BB-SYM is the symbol name of the target block." (pcase insns-seq (`((set ,(and (pred comp-mvar-p) cond) (,(pred comp-call-op-p) - ,(and (or 'eq 'eql '= 'equal) test-fn) ,op1 ,op2)) + ,(or 'eq 'eql '= 'equal) ,op1 ,op2)) (comment ,_comment-str) (cond-jump ,cond ,(pred comp-mvar-p) . ,blocks)) - (let* ((bb-1 (car blocks)) - (bb-target (comp-cond-cstr-target-block b bb-1))) - (setf (car blocks) (comp-block-name bb-target)) - (when-let ((target-slot1 (comp-cond-cstr-target-slot - (comp-mvar-slot op1) (car insns-seq) b))) - (comp-emit-assume target-slot1 op2 bb-target test-fn)) - (when-let ((target-slot2 (comp-cond-cstr-target-slot - (comp-mvar-slot op2) (car insns-seq) b))) - (comp-emit-assume target-slot2 op1 bb-target test-fn))) - (cl-return-from in-the-basic-block)))))) + (cl-loop + with target-mvar1 = (comp-cond-cstr-target-mvar op1 (car insns-seq) b) + with target-mvar2 = (comp-cond-cstr-target-mvar op2 (car insns-seq) b) + for branch-target-cell on blocks + for branch-target = (car branch-target-cell) + for assume-target = (comp-cond-cstr-target-block b branch-target) + for negated in '(nil t) + do (setf (car branch-target-cell) (comp-block-name assume-target)) + when target-mvar1 + do (comp-emit-assume target-mvar1 op2 assume-target negated) + when target-mvar2 + do (comp-emit-assume target-mvar2 op1 assume-target negated) + finally (cl-return-from in-the-basic-block))))))) (defun comp-cond-cstr (_) "Rewrite conditional branches adding appropriate 'assume' insns. @@ -2384,7 +2396,8 @@ Forward propagate immediate involed in assignments." "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-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." @@ -2430,7 +2443,8 @@ Fold the call in case." (let ((cstr (comp-cstr-f-ret cstr-f))) (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-typeset lval) (comp-cstr-typeset cstr) + (comp-mvar-neg lval) (comp-cstr-neg cstr)))))) (defun comp-fwprop-insn (insn) "Propagate within INSN." @@ -2444,21 +2458,12 @@ Fold the call in case." (comp-fwprop-call insn lval f args))) (_ (comp-mvar-propagate lval rval)))) - (`(assume ,lval ,rval ,kind) - (pcase kind - ('eq - (comp-mvar-propagate lval rval)) - ((or 'eql 'equal) - (if (or (comp-mvar-symbol-p rval) - (comp-mvar-fixnum-p rval)) - (comp-mvar-propagate lval rval) - (setf (comp-mvar-typeset lval) (comp-mvar-typeset rval)))) - ('= - (if (comp-mvar-fixnum-p rval) - (comp-mvar-propagate lval rval) - (setf (comp-mvar-typeset lval) - (unless (comp-mvar-range rval) - '(number))))))) + (`(assume ,lval (,kind . ,operands)) + (cl-ecase kind + (and + (apply #'comp-cstr-intersection lval operands)) + (not + (comp-cstr-negation lval (car operands))))) (`(setimm ,lval ,v) (setf (comp-mvar-value lval) v)) (`(phi ,lval . ,rest) commit 2a117ad3d7204fe40b12cb3ebdc88e18346fb145 Author: Andrea Corallo Date: Sun Dec 13 18:02:19 2020 +0100 * Add mvar pretty print support when dumping LIMPLE * lisp/emacs-lisp/comp.el (comp-prettyformat-mvar) (comp-prettyformat-insn): New function. (comp-log-func): Update to use `comp-prettyformat-insn'. (comp-finalize-phis): Change LIMPLE phi format to ease `comp-prettyformat-insn' destructuring. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index c6f192d1e8..24955c6a23 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -656,7 +656,7 @@ Assume allocation class 'd-default as default." (defconst comp-limple-lock-keywords `((,(rx bol "(comment" (1+ not-newline)) . font-lock-comment-face) - (,(rx "#s(" (group-n 1 "comp-mvar")) + (,(rx "#(" (group-n 1 "mvar")) (1 font-lock-function-name-face)) (,(rx bol "(" (group-n 1 "phi")) (1 font-lock-variable-name-face)) @@ -715,15 +715,30 @@ log with `comp-log-to-buffer'." (with-selected-window log-window (goto-char (point-max))))))) +(defun comp-prettyformat-mvar (mvar) + (format "#(mvar %s %s %S)" + (comp-mvar-id mvar) + (comp-mvar-slot mvar) + (comp-cstr-to-type-spec mvar))) + +(defun comp-prettyformat-insn (insn) + (cl-typecase insn + (comp-mvar (comp-prettyformat-mvar insn)) + (atom (prin1-to-string insn)) + (cons (concat "(" (mapconcat #'comp-prettyformat-insn insn " ") ")")))) + (defun comp-log-func (func verbosity) "Log function FUNC. VERBOSITY is a number between 0 and 3." (when (>= comp-verbose verbosity) (comp-log (format "\nFunction: %s\n" (comp-func-name func)) verbosity) - (cl-loop for block-name being each hash-keys of (comp-func-blocks func) - using (hash-value bb) - do (comp-log (concat "<" (symbol-name block-name) ">") verbosity) - (comp-log (comp-block-insns bb) verbosity t)))) + (cl-loop + for block-name being each hash-keys of (comp-func-blocks func) + using (hash-value bb) + do (comp-log (concat "<" (symbol-name block-name) ">") verbosity) + (cl-loop + for insn in (comp-block-insns bb) + do (comp-log (comp-prettyformat-insn insn) verbosity))))) (defun comp-log-edges (func) "Log edges in FUNC." @@ -2286,7 +2301,7 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non-nil." for e in (comp-block-in-edges b) for b = (comp-edge-src e) for in-frame = (comp-block-final-frame b) - collect (cons (aref in-frame slot-n) + collect (list (aref in-frame slot-n) (comp-block-name b)))))) (cl-loop for b being each hash-value of (comp-func-blocks comp-func) commit 5b10a0324d5e5fd975e5833f1a058274780226e2 Author: Andrea Corallo Date: Mon Dec 21 10:20:35 2020 +0100 Fix Windows build link-time zlib error (bug#45303) * src/lisp.h (md5_gz_stream): Declare. * src/comp.c (accumulate_and_process_md5) (final_process_md5, md5_gz_stream): Remove. * src/decompress.c (accumulate_and_process_md5) (final_process_md5, md5_gz_stream): Move from comp.c. diff --git a/src/comp.c b/src/comp.c index 8907993dc5..70f61bfbe1 100644 --- a/src/comp.c +++ b/src/comp.c @@ -665,94 +665,6 @@ comp_hash_string (Lisp_Object string) return digest; } -#define MD5_BLOCKSIZE 32768 /* From md5.c */ - -static char acc_buff[2 * MD5_BLOCKSIZE]; -static size_t acc_size; - -static void -accumulate_and_process_md5 (void *data, size_t len, struct md5_ctx *ctxt) -{ - eassert (len <= MD5_BLOCKSIZE); - /* We may optimize this saving some of these memcpy/move using - directly the outer buffers but so far I'll not bother. */ - memcpy (acc_buff + acc_size, data, len); - acc_size += len; - if (acc_size >= MD5_BLOCKSIZE) - { - acc_size -= MD5_BLOCKSIZE; - md5_process_block (acc_buff, MD5_BLOCKSIZE, ctxt); - memmove (acc_buff, acc_buff + MD5_BLOCKSIZE, acc_size); - } -} - -static void -final_process_md5 (struct md5_ctx *ctxt) -{ - if (acc_size) - { - md5_process_bytes (acc_buff, acc_size, ctxt); - acc_size = 0; - } -} - -static int -md5_gz_stream (FILE *source, void *resblock) -{ - z_stream stream; - unsigned char in[MD5_BLOCKSIZE]; - unsigned char out[MD5_BLOCKSIZE]; - - eassert (!acc_size); - - struct md5_ctx ctx; - md5_init_ctx (&ctx); - - /* allocate inflate state */ - stream.zalloc = Z_NULL; - stream.zfree = Z_NULL; - stream.opaque = Z_NULL; - stream.avail_in = 0; - stream.next_in = Z_NULL; - int res = inflateInit2 (&stream, MAX_WBITS + 32); - if (res != Z_OK) - return -1; - - do { - stream.avail_in = fread (in, 1, MD5_BLOCKSIZE, source); - if (ferror (source)) { - inflateEnd (&stream); - return -1; - } - if (stream.avail_in == 0) - break; - stream.next_in = in; - - do { - stream.avail_out = MD5_BLOCKSIZE; - stream.next_out = out; - res = inflate (&stream, Z_NO_FLUSH); - - if (res != Z_OK && res != Z_STREAM_END) - return -1; - - accumulate_and_process_md5 (out, MD5_BLOCKSIZE - stream.avail_out, &ctx); - } while (!stream.avail_out); - - } while (res != Z_STREAM_END); - - final_process_md5 (&ctx); - inflateEnd (&stream); - - if (res != Z_STREAM_END) - return -1; - - md5_finish_ctx (&ctx, resblock); - - return 0; -} -#undef MD5_BLOCKSIZE - static Lisp_Object comp_hash_source_file (Lisp_Object filename) { diff --git a/src/decompress.c b/src/decompress.c index 8e8f244311..afd43e13ac 100644 --- a/src/decompress.c +++ b/src/decompress.c @@ -25,6 +25,7 @@ along with GNU Emacs. If not, see . */ #include "lisp.h" #include "buffer.h" #include "composite.h" +#include "md5.h" #include @@ -66,6 +67,107 @@ init_zlib_functions (void) #endif /* WINDOWSNT */ + +#define MD5_BLOCKSIZE 32768 /* From md5.c */ + +static char acc_buff[2 * MD5_BLOCKSIZE]; +static size_t acc_size; + +static void +accumulate_and_process_md5 (void *data, size_t len, struct md5_ctx *ctxt) +{ + eassert (len <= MD5_BLOCKSIZE); + /* We may optimize this saving some of these memcpy/move using + directly the outer buffers but so far don't bother. */ + memcpy (acc_buff + acc_size, data, len); + acc_size += len; + if (acc_size >= MD5_BLOCKSIZE) + { + acc_size -= MD5_BLOCKSIZE; + md5_process_block (acc_buff, MD5_BLOCKSIZE, ctxt); + memmove (acc_buff, acc_buff + MD5_BLOCKSIZE, acc_size); + } +} + +static void +final_process_md5 (struct md5_ctx *ctxt) +{ + if (acc_size) + { + md5_process_bytes (acc_buff, acc_size, ctxt); + acc_size = 0; + } +} + +int +md5_gz_stream (FILE *source, void *resblock) +{ + z_stream stream; + unsigned char in[MD5_BLOCKSIZE]; + unsigned char out[MD5_BLOCKSIZE]; + +#ifdef WINDOWSNT + if (!zlib_initialized) + zlib_initialized = init_zlib_functions (); + if (!zlib_initialized) + { + message1 ("zlib library not found"); + return -1; + } +#endif + + eassert (!acc_size); + + struct md5_ctx ctx; + md5_init_ctx (&ctx); + + /* allocate inflate state */ + stream.zalloc = Z_NULL; + stream.zfree = Z_NULL; + stream.opaque = Z_NULL; + stream.avail_in = 0; + stream.next_in = Z_NULL; + int res = inflateInit2 (&stream, MAX_WBITS + 32); + if (res != Z_OK) + return -1; + + do { + stream.avail_in = fread (in, 1, MD5_BLOCKSIZE, source); + if (ferror (source)) { + inflateEnd (&stream); + return -1; + } + if (stream.avail_in == 0) + break; + stream.next_in = in; + + do { + stream.avail_out = MD5_BLOCKSIZE; + stream.next_out = out; + res = inflate (&stream, Z_NO_FLUSH); + + if (res != Z_OK && res != Z_STREAM_END) + return -1; + + accumulate_and_process_md5 (out, MD5_BLOCKSIZE - stream.avail_out, &ctx); + } while (!stream.avail_out); + + } while (res != Z_STREAM_END); + + final_process_md5 (&ctx); + inflateEnd (&stream); + + if (res != Z_STREAM_END) + return -1; + + md5_finish_ctx (&ctx, resblock); + + return 0; +} +#undef MD5_BLOCKSIZE + + + struct decompress_unwind_data { ptrdiff_t old_point, orig, start, nbytes; diff --git a/src/lisp.h b/src/lisp.h index 923e742eec..7dc517be72 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -4720,7 +4720,11 @@ extern void syms_of_lcms2 (void); #endif #ifdef HAVE_ZLIB + +#include + /* Defined in decompress.c. */ +extern int md5_gz_stream (FILE *, void *); extern void syms_of_decompress (void); #endif commit 2526032ea954671aa48a6ad6d924df2941a8364a Author: Andrea Corallo Date: Mon Dec 21 08:45:53 2020 +0100 * src/comp.c (eln_load_path_final_clean_up): Fix call arg order (bug#45303). diff --git a/src/comp.c b/src/comp.c index 84a80eba11..8907993dc5 100644 --- a/src/comp.c +++ b/src/comp.c @@ -4622,7 +4622,7 @@ eln_load_path_final_clean_up (void) concat2 (XCAR (dir_tail), Vcomp_native_version_dir), Qt, build_string ("\\.eln\\.old\\'"), Qnil, - Qt, return_nil, Qnil); + Qt, Qnil, return_nil); FOR_EACH_TAIL (files_in_dir) Fdelete_file (XCAR (files_in_dir), Qnil); } commit f4153cac3e0381ea63da2cdccd0ec11c4d54d1ba Author: Andrea Corallo Date: Mon Dec 21 08:35:30 2020 +0100 * src/comp.c (Fcomp__compile_ctxt_to_file): Fix sigmask store/restore. diff --git a/src/comp.c b/src/comp.c index 139cf86c4a..84a80eba11 100644 --- a/src/comp.c +++ b/src/comp.c @@ -4458,7 +4458,6 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, comp.d_ephemeral_idx = CALL1I (comp-data-container-idx, CALL1I (comp-ctxt-d-ephemeral, Vcomp_ctxt)); - sigset_t oldset; ptrdiff_t count = 0; if (!noninteractive) @@ -4472,7 +4471,7 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, #ifdef USABLE_SIGIO sigaddset (&blocked, SIGIO); #endif - pthread_sigmask (SIG_BLOCK, &blocked, &oldset); + pthread_sigmask (SIG_BLOCK, &blocked, &saved_sigset); count = SPECPDL_INDEX (); record_unwind_protect_void (restore_sigmask); } commit f244c2190259875d095be8508a959a61339263b8 Merge: 72c1a41573 1a7033f1f3 Author: Andrea Corallo Date: Sun Dec 20 22:07:48 2020 +0100 Merge remote-tracking branch 'savannah/master' into HEAD commit 72c1a41573a96a39482a001bfeb3230c471a5681 Author: Andrea Corallo Date: Sun Dec 20 20:53:22 2020 +0100 Have native compiler always preserve multibyte strings (bug#45342) * lisp/emacs-lisp/comp.el (comp-final): Escape multibyte string when offloading compilation to child process. * test/src/comp-test-funcs.el (comp-test-45342-f): New function * test/src/comp-tests.el (bug-45342): New test diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 2cff362cb9..c6f192d1e8 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2863,6 +2863,7 @@ Prepare every function for final compilation and drive the C back-end." (print-quoted t) (print-gensym t) (print-circle t) + (print-escape-multibyte t) (expr `(progn (require 'comp) (setf comp-verbose ,comp-verbose diff --git a/test/src/comp-test-funcs.el b/test/src/comp-test-funcs.el index 5fa427be19..5fc032b127 100644 --- a/test/src/comp-test-funcs.el +++ b/test/src/comp-test-funcs.el @@ -390,6 +390,11 @@ (setq dir (directory-file-name (file-name-directory dir)))) (nreverse dirlist))) +(defun comp-test-45342-f (n) + (pcase n + (1 " ➊") (2 " ➋") (3 " ➌") (4 " ➍") (5 " ➎") (6 " ➏") + (7 " ➐") (8 " ➑") (9 " ➒") (10 " ➓") (_ ""))) + ;;;;;;;;;;;;;;;;;;;; ;; Tromey's tests ;; diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index e73fc652d6..68201deffe 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -396,6 +396,11 @@ https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-03/msg00914.html." "" (comp-test-44968-f "/tmp/test/foo" "/tmp")) +(comp-deftest bug-45342 () + "Preserve multibyte immediate strings. +" + (should (string= " ➊" (comp-test-45342-f 1)))) + (defvar comp-test-primitive-advice) (comp-deftest primitive-advice () "Test effectiveness of primitive advicing." commit 3bb2fd0c58c6caf1772564524c782f8a4a3fb2b4 Author: Andrea Corallo Date: Sun Dec 20 19:49:10 2020 +0100 * Fix missing 'gcc_jit_type_get_const' macro definition (bug#45303). * src/comp.c (gcc_jit_type_get_pointer): Define macro. diff --git a/src/comp.c b/src/comp.c index 12c5f1c7e4..139cf86c4a 100644 --- a/src/comp.c +++ b/src/comp.c @@ -376,6 +376,7 @@ init_gccjit_functions (void) #define gcc_jit_rvalue_get_type fn_gcc_jit_rvalue_get_type #define gcc_jit_struct_as_type fn_gcc_jit_struct_as_type #define gcc_jit_struct_set_fields fn_gcc_jit_struct_set_fields +#define gcc_jit_type_get_const fn_gcc_jit_type_get_const #define gcc_jit_type_get_pointer fn_gcc_jit_type_get_pointer #define gcc_jit_version_major fn_gcc_jit_version_major #define gcc_jit_version_minor fn_gcc_jit_version_minor commit ab985f41db5fdaeada513d28a065332fd8838cf4 Author: Andrea Corallo Date: Sat Dec 19 21:02:49 2020 +0100 Add 'internal_condition_case_5' (bug#45303). * src/lisp.h (internal_condition_case_4) (internal_condition_case_5): Declare. * src/eval.c (internal_condition_case_5): New function. * src/comp.c (eln_load_path_final_clean_up): Use 'internal_condition_case_5'. diff --git a/src/comp.c b/src/comp.c index f77faaa483..12c5f1c7e4 100644 --- a/src/comp.c +++ b/src/comp.c @@ -4618,11 +4618,11 @@ eln_load_path_final_clean_up (void) FOR_EACH_TAIL (dir_tail) { Lisp_Object files_in_dir = - internal_condition_case_4 (Fdirectory_files, + internal_condition_case_5 (Fdirectory_files, concat2 (XCAR (dir_tail), Vcomp_native_version_dir), Qt, build_string ("\\.eln\\.old\\'"), Qnil, - Qt, return_nil); + Qt, return_nil, Qnil); FOR_EACH_TAIL (files_in_dir) Fdelete_file (XCAR (files_in_dir), Qnil); } diff --git a/src/eval.c b/src/eval.c index 2b31b91175..368fa0944a 100644 --- a/src/eval.c +++ b/src/eval.c @@ -1534,6 +1534,35 @@ internal_condition_case_4 (Lisp_Object (*bfun) (Lisp_Object, Lisp_Object, } } +/* Like internal_condition_case_1 but call BFUN with ARG1, ARG2, ARG3, + ARG4, ARG5 as its arguments. */ + +Lisp_Object +internal_condition_case_5 (Lisp_Object (*bfun) (Lisp_Object, Lisp_Object, + Lisp_Object, Lisp_Object, + Lisp_Object), + Lisp_Object arg1, Lisp_Object arg2, + Lisp_Object arg3, Lisp_Object arg4, + Lisp_Object arg5, Lisp_Object handlers, + Lisp_Object (*hfun) (Lisp_Object)) +{ + struct handler *c = push_handler (handlers, CONDITION_CASE); + if (sys_setjmp (c->jmp)) + { + Lisp_Object val = handlerlist->val; + clobbered_eassert (handlerlist == c); + handlerlist = handlerlist->next; + return hfun (val); + } + else + { + Lisp_Object val = bfun (arg1, arg2, arg3, arg4, arg5); + eassert (handlerlist == c); + handlerlist = c->next; + return val; + } +} + /* Like internal_condition_case but call BFUN with NARGS as first, and ARGS as second argument. */ diff --git a/src/lisp.h b/src/lisp.h index 588316e01b..923e742eec 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -4157,6 +4157,8 @@ extern Lisp_Object internal_condition_case (Lisp_Object (*) (void), Lisp_Object, extern Lisp_Object internal_condition_case_1 (Lisp_Object (*) (Lisp_Object), Lisp_Object, Lisp_Object, Lisp_Object (*) (Lisp_Object)); extern Lisp_Object internal_condition_case_2 (Lisp_Object (*) (Lisp_Object, Lisp_Object), Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object (*) (Lisp_Object)); extern Lisp_Object internal_condition_case_3 (Lisp_Object (*) (Lisp_Object, Lisp_Object, Lisp_Object), Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object (*) (Lisp_Object)); +extern Lisp_Object internal_condition_case_4 (Lisp_Object (*) (Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object), Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object (*) (Lisp_Object)); +extern Lisp_Object internal_condition_case_5 (Lisp_Object (*) (Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object), Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object (*) (Lisp_Object)); extern Lisp_Object internal_condition_case_n (Lisp_Object (*) (ptrdiff_t, Lisp_Object *), ptrdiff_t, Lisp_Object *, Lisp_Object, Lisp_Object (*) (Lisp_Object, ptrdiff_t, Lisp_Object *)); commit 407fb165832341d3dccb78d2782d1790a19c4b9d Author: Andrea Corallo Date: Sat Dec 19 20:45:56 2020 +0100 * Add 'gcc_jit_type_get_const' to Windows dynamic load machinery (bug#45303). * src/comp.c: Add 'gcc_jit_type_get_const' to windows dynamic load machinery. diff --git a/src/comp.c b/src/comp.c index b52e7e34ae..f77faaa483 100644 --- a/src/comp.c +++ b/src/comp.c @@ -102,6 +102,7 @@ along with GNU Emacs. If not, see . */ #undef gcc_jit_rvalue_get_type #undef gcc_jit_struct_as_type #undef gcc_jit_struct_set_fields +#undef gcc_jit_type_get_const #undef gcc_jit_type_get_pointer #undef gcc_jit_version_major #undef gcc_jit_version_minor @@ -208,6 +209,7 @@ DEF_DLL_FN (gcc_jit_type *, gcc_jit_context_new_union_type, DEF_DLL_FN (gcc_jit_type *, gcc_jit_rvalue_get_type, (gcc_jit_rvalue *rvalue)); DEF_DLL_FN (gcc_jit_type *, gcc_jit_struct_as_type, (gcc_jit_struct *struct_type)); +DEF_DLL_FN (gcc_jit_type *, gcc_jit_type_get_const, (gcc_jit_type *type)); DEF_DLL_FN (gcc_jit_type *, gcc_jit_type_get_pointer, (gcc_jit_type *type)); DEF_DLL_FN (void, gcc_jit_block_add_assignment, (gcc_jit_block *block, gcc_jit_location *loc, gcc_jit_lvalue *lvalue, @@ -308,6 +310,7 @@ init_gccjit_functions (void) LOAD_DLL_FN (library, gcc_jit_rvalue_get_type); LOAD_DLL_FN (library, gcc_jit_struct_as_type); LOAD_DLL_FN (library, gcc_jit_struct_set_fields); + LOAD_DLL_FN (library, gcc_jit_type_get_const); LOAD_DLL_FN (library, gcc_jit_type_get_pointer); LOAD_DLL_FN_OPT (library, gcc_jit_context_add_driver_option); LOAD_DLL_FN_OPT (library, gcc_jit_global_set_initializer); commit 3b53a591faed03679382a601b93da7fe6ce3b4af Author: Andrea Corallo Date: Sat Dec 19 08:46:56 2020 +0100 * Clean-up 'internal_condition_case_4' orphan declaration (bug#45303). * src/lisp.h (internal_condition_case_4): Declaration remove. diff --git a/src/lisp.h b/src/lisp.h index 5900b8d25e..588316e01b 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -4157,7 +4157,6 @@ extern Lisp_Object internal_condition_case (Lisp_Object (*) (void), Lisp_Object, extern Lisp_Object internal_condition_case_1 (Lisp_Object (*) (Lisp_Object), Lisp_Object, Lisp_Object, Lisp_Object (*) (Lisp_Object)); extern Lisp_Object internal_condition_case_2 (Lisp_Object (*) (Lisp_Object, Lisp_Object), Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object (*) (Lisp_Object)); extern Lisp_Object internal_condition_case_3 (Lisp_Object (*) (Lisp_Object, Lisp_Object, Lisp_Object), Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object (*) (Lisp_Object)); -extern Lisp_Object internal_condition_case_4 (Lisp_Object (*) (Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object), Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object (*) (Lisp_Object)); extern Lisp_Object internal_condition_case_n (Lisp_Object (*) (ptrdiff_t, Lisp_Object *), ptrdiff_t, Lisp_Object *, Lisp_Object, Lisp_Object (*) (Lisp_Object, ptrdiff_t, Lisp_Object *)); commit eeac3f4db4e3cdd0fc71541c827466927334dce4 Author: Andrea Corallo Date: Sat Dec 19 08:34:59 2020 +0100 * Move diagnostic pragmas out of namespace-scope (bug#45303). Pragmas in GCC don't work reliably within function: * src/comp.c (emit_static_object) (Fcomp_native_driver_options_effective_p) (Fcomp_libgccjit_version): Move pragmas out of name-scope. diff --git a/src/comp.c b/src/comp.c index 1842aeb839..b52e7e34ae 100644 --- a/src/comp.c +++ b/src/comp.c @@ -2493,6 +2493,7 @@ emit_maybe_gc_or_quit (Lisp_Object insn) /* This is in charge of serializing an object and export a function to retrieve it at load time. */ +#pragma GCC diagnostic ignored "-Waddress" static void emit_static_object (const char *name, Lisp_Object obj) { @@ -2521,9 +2522,7 @@ emit_static_object (const char *name, Lisp_Object obj) #if defined (LIBGCCJIT_HAVE_gcc_jit_global_set_initializer) \ || defined (WINDOWSNT) -#pragma GCC diagnostic ignored "-Waddress" if (gcc_jit_global_set_initializer) -#pragma GCC diagnostic pop { ptrdiff_t str_size = len + 1; ptrdiff_t size = sizeof (static_obj_t) + str_size; @@ -2682,6 +2681,7 @@ emit_static_object (const char *name, Lisp_Object obj) gcc_jit_rvalue *res = gcc_jit_lvalue_get_address (data_struct, NULL); gcc_jit_block_end_with_return (block, NULL, res); } +#pragma GCC diagnostic pop static gcc_jit_rvalue * declare_imported_data_relocs (Lisp_Object container, const char *code_symbol, @@ -4363,6 +4363,7 @@ DEFUN ("comp--release-ctxt", Fcomp__release_ctxt, Scomp__release_ctxt, return Qt; } +#pragma GCC diagnostic ignored "-Waddress" DEFUN ("comp-native-driver-options-effective-p", Fcomp_native_driver_options_effective_p, Scomp_native_driver_options_effective_p, @@ -4372,14 +4373,12 @@ DEFUN ("comp-native-driver-options-effective-p", { #if defined (LIBGCCJIT_HAVE_gcc_jit_context_add_driver_option) \ || defined (WINDOWSNT) -#pragma GCC diagnostic ignored "-Waddress" if (gcc_jit_context_add_driver_option) return Qt; -#pragma GCC diagnostic pop #endif return Qnil; } - +#pragma GCC diagnostic pop static void add_driver_options (void) @@ -4526,6 +4525,7 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, return filename; } +#pragma GCC diagnostic ignored "-Waddress" DEFUN ("comp-libgccjit-version", Fcomp_libgccjit_version, Scomp_libgccjit_version, 0, 0, 0, doc: /* Return libgccjit version in use. @@ -4537,19 +4537,16 @@ unknown (before GCC version 10). */) #if defined (LIBGCCJIT_HAVE_gcc_jit_version) || defined (WINDOWSNT) load_gccjit_if_necessary (true); - /* FIXME this kludge is quite bad. Can we dynamically load on all - operating systems? */ -#pragma GCC diagnostic ignored "-Waddress" return gcc_jit_version_major ? list3 (make_fixnum (gcc_jit_version_major ()), make_fixnum (gcc_jit_version_minor ()), make_fixnum (gcc_jit_version_patchlevel ())) : Qnil; -#pragma GCC diagnostic pop #else return Qnil; #endif } +#pragma GCC diagnostic pop /******************************************************************************/ commit 49f81d6a531283416d3a87e46ee6696eea971b64 Author: Andrea Corallo Date: Sat Dec 19 07:40:24 2020 +0100 Fix Windows libgccjit library name (bug#45303). * lisp/term/w32-win.el (dynamic-library-alist): Fix Windows libgccjit library name. * src/emacs.c (syms_of_emacs): Likewise. diff --git a/lisp/term/w32-win.el b/lisp/term/w32-win.el index 4ed2710a55..1fcfca5dfd 100644 --- a/lisp/term/w32-win.el +++ b/lisp/term/w32-win.el @@ -285,7 +285,7 @@ See the documentation of `create-fontset-from-fontset-spec' for the format.") '(zlib "zlib1.dll" "libz-1.dll") '(lcms2 "liblcms2-2.dll") '(json "libjansson-4.dll") - '(gccjit "libgccjit.dll"))) + '(gccjit "libgccjit-0.dll"))) ;;; multi-tty support (defvar w32-initialized nil diff --git a/src/emacs.c b/src/emacs.c index afdfcade77..4b3f4c7305 100644 --- a/src/emacs.c +++ b/src/emacs.c @@ -3084,10 +3084,10 @@ libraries; only those already known by Emacs will be loaded. */); #ifdef WINDOWSNT /* We may need to load libgccjit when dumping before term/w32-win.el defines `dynamic-library-alist`. This will fail if that variable - is empty, so add libgccjit.dll to it. */ + is empty, so add libgccjit-0.dll to it. */ if (will_dump_p ()) Vdynamic_library_alist = list1 (list2 (Qgccjit, - build_string ("libgccjit.dll"))); + build_string ("libgccjit-0.dll"))); else Vdynamic_library_alist = Qnil; #else commit 87f6e937995c433825173fb0473a801791d5beac Author: Andrea Corallo Date: Thu Dec 17 22:07:39 2020 +0100 * Makefile.in (w32locallisppath): Add PATH_REL_LOADSEARCH (bug#45303). diff --git a/Makefile.in b/Makefile.in index 027dca0bd7..8a9c23c901 100644 --- a/Makefile.in +++ b/Makefile.in @@ -403,6 +403,7 @@ epaths-force-w32: w32locallisppath=$${w32locallisppath//$${w32prefix}/"%emacs_dir%"} ; \ sed < ${srcdir}/nt/epaths.nt > epaths.h.$$$$ \ -e 's;\(#.*PATH_SITELOADSEARCH\).*$$;\1 "'"$${w32locallisppath//;/\\;}"'";' \ + -e 's;\(#.*PATH_REL_LOADSEARCH\).*$$;\1 "${lispdirrel}";' \ -e '/^.*#/s/@VER@/${version}/g' \ -e '/^.*#/s/@CFG@/${configuration}/g' \ -e "/^.*#/s|@SRC@|$${w32srcdir}|g") && \ commit 174f2a92ebe4cee9d7a50fb443079636943f7be6 Author: Andrea Corallo Date: Thu Dec 17 21:51:22 2020 +0100 * nt/epaths.nt (PATH_REL_LOADSEARCH): Define macro (bug#45303). diff --git a/nt/epaths.nt b/nt/epaths.nt index 62e7749063..a61bcb944b 100644 --- a/nt/epaths.nt +++ b/nt/epaths.nt @@ -49,6 +49,11 @@ along with GNU Emacs. If not, see . */ */ #define PATH_SITELOADSEARCH "%emacs_dir%/share/emacs/@VER@/site-lisp;%emacs_dir%/share/emacs/site-lisp" +/* Like PATH_LOADSEARCH, but contains the relative path from the + installation directory. +*/ +#define PATH_REL_LOADSEARCH "" + /* Like PATH_LOADSEARCH, but used only during the build process when Emacs is dumping. Configure (using "make epaths-force-w32") sets this to $buildlisppath, which normally has the value: /lisp. commit 682bd303470d4a0fcd2690aff6aa58fb720a8d41 Author: Andrea Corallo Date: Sat Dec 12 22:20:28 2020 +0100 * Allow for adding constraints targetting blocks with multiple predecessors This commit remove the limitaiton we had not being able to add constraints derived from conditional branches to basic blocks with multiple predecessors. When this condition is verified we add a new dedicated basic block to hold the constraints. * lisp/emacs-lisp/comp.el (comp-block, comp-edge): Better slot type specifiers. (comp-block-cstr): New struct specializing `comp-block'. (make-comp-edge): New function. (comp-func): Better test function + doc for `blocks' slot. (comp-limple-lock-keywords): Update possible basic block names. (comp-emit-assume): Recive directly the block instead of its name. (comp-add-new-block-beetween): New function. (comp-cond-cstr-target-block): Logic update and use `comp-add-new-block-beetween'. (comp-cond-cstr-func): Make use of the latter. (comp-compute-edges): Make use of `make-comp-edge'. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index b9a511ab86..2cff362cb9 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -313,6 +313,9 @@ Useful to hook into pass checkers.") return) "All limple operators.") +(defvar comp-func nil + "Bound to the current function by most passes.") + (define-error 'native-compiler-error-dyn-func "can't native compile a non-lexically-scoped function" 'native-compiler-error) @@ -400,13 +403,13 @@ To be used when ncall-conv is nil.")) :documentation "List of incoming edges.") (out-edges () :type list :documentation "List of out-coming edges.") - (dom nil :type comp-block + (dom nil :type (or null comp-block) :documentation "Immediate dominator.") - (df (make-hash-table) :type hash-table + (df (make-hash-table) :type (or null hash-table) :documentation "Dominance frontier set. Block-name -> block") - (post-num nil :type number + (post-num nil :type (or null number) :documentation "Post order number.") - (final-frame nil :type vector + (final-frame nil :type (or null vector) :documentation "This is a copy of the frame when leaving the block. Is in use to help the SSA rename pass.")) @@ -426,14 +429,26 @@ into it.") (:include comp-block)) "A basic block for a latch loop.") +(cl-defstruct (comp-block-cstr (:copier nil) + (:include comp-block)) + "A basic block holding only constraints.") + (cl-defstruct (comp-edge (:copier nil) (:constructor make--comp-edge)) "An edge connecting two basic blocks." - (src nil :type comp-block) - (dst nil :type comp-block) + (src nil :type (or null comp-block)) + (dst nil :type (or null comp-block)) (number nil :type number :documentation "The index number corresponding to this edge in the edge hash.")) +(defun make-comp-edge (&rest args) + "Create a `comp-edge' with basic blocks SRC and DST." + (let ((n (funcall (comp-func-edge-cnt-gen comp-func)))) + (puthash + n + (apply #'make--comp-edge :number n args) + (comp-func-edges-h comp-func)))) + (defun comp-block-preds (basic-block) "Given BASIC-BLOCK return the list of its predecessors." (mapcar #'comp-edge-src (comp-block-in-edges basic-block))) @@ -463,8 +478,8 @@ into it.") Once in SSA form this *must* be set to 'dirty' every time the topology of the CFG is mutated by a pass.") (frame-size nil :type number) - (blocks (make-hash-table) :type hash-table - :documentation "Basic block name -> basic block.") + (blocks (make-hash-table :test #'eq) :type hash-table + :documentation "Basic block symbol -> basic block.") (lap-block (make-hash-table :test #'equal) :type hash-table :documentation "LAP label -> LIMPLE basic block name.") (edges-h (make-hash-table) :type hash-table @@ -570,9 +585,6 @@ In use by the backend." (cons (comp-mvar-cons-p mvar)) (fixnum (comp-mvar-fixnum-p mvar)))) -;; Special vars used by some passes -(defvar comp-func) - (defun comp-ensure-native-compiler () @@ -650,7 +662,7 @@ Assume allocation class 'd-default as default." (1 font-lock-variable-name-face)) (,(rx (group-n 1 (or "entry" (seq (or "entry_" "entry_fallback_" "bb_") - (1+ num) (? "_latch"))))) + (1+ num) (? (or "_latch" "_cstrs")))))) (1 font-lock-constant-face)) (,(rx-to-string `(seq "(" (group-n 1 (or ,@(mapcar #'symbol-name comp-limple-ops))))) @@ -1841,12 +1853,11 @@ into the C code forwarding the compilation unit." ;;; conditional branches rewrite pass specific code. -(defun comp-emit-assume (target-slot rhs bb-name kind) +(defun comp-emit-assume (target-slot rhs bb kind) "Emit an assume of kind KIND for TARGET-SLOT being RHS. -The assume is emitted at the beginning of the block named -BB-NAME." +The assume is emitted at the beginning of the block BB." (push `(assume ,(make-comp-mvar :slot target-slot) ,rhs ,kind) - (comp-block-insns (gethash bb-name (comp-func-blocks comp-func)))) + (comp-block-insns bb)) (setf (comp-func-ssa-status comp-func) 'dirty)) (defun comp-cond-cstr-target-slot (slot-num exit-insn bb) @@ -1867,34 +1878,67 @@ Return the corresponding rhs slot number." (setf res rhs))) finally (cl-assert nil)))) +(defun comp-add-new-block-beetween (bb-symbol bb-a bb-b) + "Create a new basic-block named BB-SYMBOL and add it between BB-A and BB-B." + (cl-loop + with new-bb = (make-comp-block-cstr :name bb-symbol + :insns `((jump ,(comp-block-name bb-b)))) + with new-edge = (make-comp-edge :src bb-a :dst new-bb) + for ed in (comp-block-in-edges bb-b) + when (eq (comp-edge-src ed) bb-a) + do + ;; Connect `ed' to `new-bb' and disconnect it from `bb-a'. + (cl-assert (memq ed (comp-block-out-edges bb-a))) + (setf (comp-edge-src ed) new-bb + (comp-block-out-edges bb-a) (delq ed (comp-block-out-edges bb-a))) + (push ed (comp-block-out-edges new-bb)) + ;; Connect `bb-a' `new-bb' with `new-edge'. + (push (comp-block-out-edges bb-a) new-edge) + (push (comp-block-in-edges new-bb) new-edge) + (setf (comp-func-ssa-status comp-func) 'dirty) + ;; Add `new-edge' to the current function and return it. + (cl-return (puthash bb-symbol new-bb (comp-func-blocks comp-func))) + finally (cl-assert nil))) + +(defun comp-cond-cstr-target-block (curr-bb target-bb-sym) + "Return the appropriate basic block to add constraint assumptions into. +CURR-BB is the current basic block. +TARGET-BB-SYM is the symbol name of the target block." + (let ((target-bb (gethash target-bb-sym + (comp-func-blocks comp-func)))) + (if (= (length (comp-block-in-edges target-bb)) 1) + ;; If block has only one predecessor is already suitable for + ;; adding constraint assumptions. + target-bb + (comp-add-new-block-beetween (intern (concat (symbol-name target-bb-sym) + "_cstrs")) + curr-bb target-bb)))) + (defun comp-cond-cstr-func () "`comp-cond-cstr' worker function for each selected function." (cl-loop for b being each hash-value of (comp-func-blocks comp-func) - do (cl-loop - named in-the-basic-block - for insns-seq on (comp-block-insns b) - do (pcase insns-seq - (`((set ,(and (pred comp-mvar-p) cond) - (,(pred comp-call-op-p) - ,(and (or 'eq 'eql '= 'equal) test-fn) ,op1 ,op2)) - (comment ,_comment-str) - (cond-jump ,cond ,(pred comp-mvar-p) ,bb-1 ,_bb-2)) - ;; FIXME We guard the target block against having more - ;; then one predecessor. The right fix will be to add a - ;; new dedicated basic block for the assumptions so we - ;; can proceed always. - (when (= (length (comp-block-in-edges - (gethash bb-1 - (comp-func-blocks comp-func)))) - 1) - (when-let ((target-slot1 (comp-cond-cstr-target-slot - (comp-mvar-slot op1) (car insns-seq) b))) - (comp-emit-assume target-slot1 op2 bb-1 test-fn)) - (when-let ((target-slot2 (comp-cond-cstr-target-slot - (comp-mvar-slot op2) (car insns-seq) b))) - (comp-emit-assume target-slot2 op1 bb-1 test-fn))) - (cl-return-from in-the-basic-block)))))) + do + (cl-loop + named in-the-basic-block + for insns-seq on (comp-block-insns b) + do + (pcase insns-seq + (`((set ,(and (pred comp-mvar-p) cond) + (,(pred comp-call-op-p) + ,(and (or 'eq 'eql '= 'equal) test-fn) ,op1 ,op2)) + (comment ,_comment-str) + (cond-jump ,cond ,(pred comp-mvar-p) . ,blocks)) + (let* ((bb-1 (car blocks)) + (bb-target (comp-cond-cstr-target-block b bb-1))) + (setf (car blocks) (comp-block-name bb-target)) + (when-let ((target-slot1 (comp-cond-cstr-target-slot + (comp-mvar-slot op1) (car insns-seq) b))) + (comp-emit-assume target-slot1 op2 bb-target test-fn)) + (when-let ((target-slot2 (comp-cond-cstr-target-slot + (comp-mvar-slot op2) (car insns-seq) b))) + (comp-emit-assume target-slot2 op1 bb-target test-fn))) + (cl-return-from in-the-basic-block)))))) (defun comp-cond-cstr (_) "Rewrite conditional branches adding appropriate 'assume' insns. @@ -2002,45 +2046,38 @@ blocks." (defun comp-compute-edges () "Compute the basic block edges for the current function." - (cl-flet ((edge-add (&rest args &aux (n (funcall - (comp-func-edge-cnt-gen comp-func)))) - (puthash - n - (apply #'make--comp-edge :number n args) - (comp-func-edges-h comp-func)))) - - (cl-loop with blocks = (comp-func-blocks comp-func) - for bb being each hash-value of blocks - for last-insn = (car (last (comp-block-insns bb))) - for (op first second third forth) = last-insn - do (cl-case op - (jump - (edge-add :src bb :dst (gethash first blocks))) - (cond-jump - (edge-add :src bb :dst (gethash third blocks)) - (edge-add :src bb :dst (gethash forth blocks))) - (cond-jump-narg-leq - (edge-add :src bb :dst (gethash second blocks)) - (edge-add :src bb :dst (gethash third blocks))) - (push-handler - (edge-add :src bb :dst (gethash third blocks)) - (edge-add :src bb :dst (gethash forth blocks))) - (return) - (otherwise - (signal 'native-ice - (list "block does not end with a branch" - bb - (comp-func-name comp-func))))) - ;; Update edge refs into blocks. - finally - (cl-loop - for edge being the hash-value in (comp-func-edges-h comp-func) - do - (push edge - (comp-block-out-edges (comp-edge-src edge))) - (push edge - (comp-block-in-edges (comp-edge-dst edge)))) - (comp-log-edges comp-func)))) + (cl-loop with blocks = (comp-func-blocks comp-func) + for bb being each hash-value of blocks + for last-insn = (car (last (comp-block-insns bb))) + for (op first second third forth) = last-insn + do (cl-case op + (jump + (make-comp-edge :src bb :dst (gethash first blocks))) + (cond-jump + (make-comp-edge :src bb :dst (gethash third blocks)) + (make-comp-edge :src bb :dst (gethash forth blocks))) + (cond-jump-narg-leq + (make-comp-edge :src bb :dst (gethash second blocks)) + (make-comp-edge :src bb :dst (gethash third blocks))) + (push-handler + (make-comp-edge :src bb :dst (gethash third blocks)) + (make-comp-edge :src bb :dst (gethash forth blocks))) + (return) + (otherwise + (signal 'native-ice + (list "block does not end with a branch" + bb + (comp-func-name comp-func))))) + ;; Update edge refs into blocks. + finally + (cl-loop + for edge being the hash-value in (comp-func-edges-h comp-func) + do + (push edge + (comp-block-out-edges (comp-edge-src edge))) + (push edge + (comp-block-in-edges (comp-edge-dst edge)))) + (comp-log-edges comp-func))) (defun comp-collect-rev-post-order (basic-block) "Walk BASIC-BLOCK children and return their name in reversed post-order." commit 258eaddef8979d8ec6decb1ff4b11cab4be05e8b Author: Andrea Corallo Date: Sat Dec 12 20:56:32 2020 +0100 * Rename comp-cond-rw -> comp-cond-cstr * lisp/emacs-lisp/comp.el (comp-passes) (comp-cond-cstr-target-slot, comp-cond-cstr-func) (comp-cond-cstr): Rename pass from cond-rw to cond-cstr. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 339fff7aa1..b9a511ab86 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -164,7 +164,7 @@ Can be one of: 'd-default', 'd-impure' or 'd-ephemeral'. See `comp-ctxt'.") comp-fwprop comp-call-optim comp-ipa-pure - comp-cond-rw + comp-cond-cstr comp-fwprop comp-dead-code comp-tco @@ -1849,7 +1849,7 @@ BB-NAME." (comp-block-insns (gethash bb-name (comp-func-blocks comp-func)))) (setf (comp-func-ssa-status comp-func) 'dirty)) -(defun comp-cond-rw-target-slot (slot-num exit-insn bb) +(defun comp-cond-cstr-target-slot (slot-num exit-insn bb) "Search for the last assignment of SLOT-NUM in BB. Keep on searching till EXIT-INSN is encountered. Return the corresponding rhs slot number." @@ -1867,8 +1867,8 @@ Return the corresponding rhs slot number." (setf res rhs))) finally (cl-assert nil)))) -(defun comp-cond-rw-func () - "`comp-cond-rw' worker function for each selected function." +(defun comp-cond-cstr-func () + "`comp-cond-cstr' worker function for each selected function." (cl-loop for b being each hash-value of (comp-func-blocks comp-func) do (cl-loop @@ -1888,15 +1888,15 @@ Return the corresponding rhs slot number." (gethash bb-1 (comp-func-blocks comp-func)))) 1) - (when-let ((target-slot1 (comp-cond-rw-target-slot + (when-let ((target-slot1 (comp-cond-cstr-target-slot (comp-mvar-slot op1) (car insns-seq) b))) (comp-emit-assume target-slot1 op2 bb-1 test-fn)) - (when-let ((target-slot2 (comp-cond-rw-target-slot + (when-let ((target-slot2 (comp-cond-cstr-target-slot (comp-mvar-slot op2) (car insns-seq) b))) (comp-emit-assume target-slot2 op1 bb-1 test-fn))) (cl-return-from in-the-basic-block)))))) -(defun comp-cond-rw (_) +(defun comp-cond-cstr (_) "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 @@ -1909,7 +1909,7 @@ blocks." (comp-func-l-p f) (not (comp-func-has-non-local f))) (let ((comp-func f)) - (comp-cond-rw-func) + (comp-cond-cstr-func) (comp-log-func comp-func 3)))) (comp-ctxt-funcs-h comp-ctxt))) commit 5ca371b5011879ad0a3fa8e0c8fae6c3ef8356b4 Author: Andrea Corallo Date: Sat Dec 12 20:43:04 2020 +0100 * Memoize `comp-cstr-intersection' * lisp/emacs-lisp/comp-cstr.el (comp-cstr-ctxt): Add new slot `intersection-mem'. (comp-cstr-intersection-homogeneous): Fix non local exit target. (comp-cstr-intersection-no-mem): Rename from `comp-cstr-intersection'. (comp-cstr-intersection): New function. diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el index ba93ee948d..6bacd24176 100644 --- a/lisp/emacs-lisp/comp-cstr.el +++ b/lisp/emacs-lisp/comp-cstr.el @@ -91,7 +91,10 @@ Integer values are handled in the `range' slot.") `comp-cstr-union-1'.") (union-1-mem-range (make-hash-table :test #'equal) :type hash-table :documentation "Serve memoization for -`comp-cstr-union-1'.")) +`comp-cstr-union-1'.") + (intersection-mem (make-hash-table :test #'equal) :type hash-table + :documentation "Serve memoization for +`intersection-mem'.")) (defmacro with-comp-cstr-accessors (&rest body) "Define some quick accessor to reduce code vergosity in BODY." @@ -526,7 +529,7 @@ DST is returned." (setf (comp-cstr-valset dst) nil (comp-cstr-range dst) nil (comp-cstr-typeset dst) nil) - (cl-return-from comp-cstr-intersection dst)) + (cl-return-from comp-cstr-intersection-homogeneous dst)) ;; TODO memoize? (setf (comp-cstr-range dst) (apply #'comp-range-intersection @@ -551,26 +554,9 @@ DST is returned." (mapcar #'comp-cstr-typeset srcs)))) dst) - -;;; Entry points. - -(defun comp-cstr-union-no-range (dst &rest srcs) - "Combine SRCS by union set operation setting the result in DST. -Do not propagate the range component. -DST is returned." - (apply #'comp-cstr-union-1 nil dst srcs)) - -(defun comp-cstr-union (dst &rest srcs) - "Combine SRCS by union set operation setting the result in DST. -DST is returned." - (apply #'comp-cstr-union-1 t dst srcs)) - -(defun comp-cstr-union-make (&rest srcs) - "Combine SRCS by union set operation and return a new constraint." - (apply #'comp-cstr-union (make-comp-cstr) srcs)) - -(cl-defun comp-cstr-intersection (dst &rest srcs) +(cl-defun comp-cstr-intersection-no-mem (dst &rest srcs) "Combine SRCS by intersection set operation setting the result in DST. +Non memoized version of `comp-cstr-intersection-no-mem'. DST is returned." (with-comp-cstr-accessors (cl-flet ((return-empty () @@ -578,11 +564,11 @@ DST is returned." (valset dst) () (range dst) () (neg dst) nil) - (cl-return-from comp-cstr-intersection dst))) + (cl-return-from comp-cstr-intersection-no-mem dst))) (when-let ((res (comp-cstrs-homogeneous srcs))) (apply #'comp-cstr-intersection-homogeneous dst srcs) (setf (neg dst) (eq res 'neg)) - (cl-return-from comp-cstr-intersection dst)) + (cl-return-from comp-cstr-intersection-no-mem dst)) ;; Some are negated and some are not (cl-multiple-value-bind (positives negatives) (comp-split-pos-neg srcs) @@ -598,7 +584,7 @@ DST is returned." (valset dst) (valset neg) (range dst) (range neg) (neg dst) t) - (cl-return-from comp-cstr-intersection dst)) + (cl-return-from comp-cstr-intersection-no-mem dst)) (when (cl-some (lambda (ty) @@ -641,6 +627,40 @@ DST is returned." (neg dst) nil))) dst))) + +;;; Entry points. + +(defun comp-cstr-union-no-range (dst &rest srcs) + "Combine SRCS by union set operation setting the result in DST. +Do not propagate the range component. +DST is returned." + (apply #'comp-cstr-union-1 nil dst srcs)) + +(defun comp-cstr-union (dst &rest srcs) + "Combine SRCS by union set operation setting the result in DST. +DST is returned." + (apply #'comp-cstr-union-1 t dst srcs)) + +(defun comp-cstr-union-make (&rest srcs) + "Combine SRCS by union set operation and return a new constraint." + (apply #'comp-cstr-union (make-comp-cstr) srcs)) + +(defun comp-cstr-intersection (dst &rest srcs) + "Combine SRCS by intersection set operation setting the result in DST. +DST is returned." + (let ((mem-h (comp-cstr-ctxt-intersection-mem comp-ctxt))) + (with-comp-cstr-accessors + (if-let ((mem-res (gethash srcs mem-h))) + (progn + (setf (typeset dst) (typeset mem-res) + (valset dst) (valset mem-res) + (range dst) (range mem-res) + (neg dst) (neg mem-res)) + mem-res) + (let ((res (apply #'comp-cstr-intersection-no-mem dst srcs))) + (puthash srcs (comp-cstr-copy res) mem-h) + res))))) + (defun comp-cstr-intersection-make (&rest srcs) "Combine SRCS by intersection set operation and return a new constraint." (apply #'comp-cstr-intersection (make-comp-cstr) srcs)) commit 0ded37fdadc96e7607e2a13e0fd0990e13f3b0b4 Author: Andrea Corallo Date: Tue Dec 8 21:24:14 2020 +0100 * Add initial negated non-negegated intersection support * lisp/emacs-lisp/comp-cstr.el (comp-range-intersection): Cosmetic. (comp-cstr-intersection-homogeneous): Rename from `comp-cstr-intersection'. (comp-cstr-intersection): New function. diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el index 6991c9305f..ba93ee948d 100644 --- a/lisp/emacs-lisp/comp-cstr.el +++ b/lisp/emacs-lisp/comp-cstr.el @@ -302,11 +302,11 @@ Return them as multiple value." with nest = 0 with low = nil with res = () + for (i . x) in (cl-sort (nconc lows highs) #'comp-range-< :key #'car) initially (when (cl-some #'null ranges) ;; Intersecting with a null range always results in a ;; null range. (cl-return '())) - for (i . x) in (cl-sort (nconc lows highs) #'comp-range-< :key #'car) if (eq x 'l) do (cl-incf nest) @@ -502,27 +502,9 @@ DST is returned." (puthash srcs (comp-cstr-copy res) mem-h) res))))) - -;;; Entry points. - -(defun comp-cstr-union-no-range (dst &rest srcs) - "Combine SRCS by union set operation setting the result in DST. -Do not propagate the range component. -DST is returned." - (apply #'comp-cstr-union-1 nil dst srcs)) - -(defun comp-cstr-union (dst &rest srcs) - "Combine SRCS by union set operation setting the result in DST. -DST is returned." - (apply #'comp-cstr-union-1 t dst srcs)) - -(defun comp-cstr-union-make (&rest srcs) - "Combine SRCS by union set operation and return a new constraint." - (apply #'comp-cstr-union (make-comp-cstr) srcs)) - -;; TODO memoize -(cl-defun comp-cstr-intersection (dst &rest srcs) +(cl-defun comp-cstr-intersection-homogeneous (dst &rest srcs) "Combine SRCS by intersection set operation setting the result in DST. +All SRCS constraints must be homogeneously negated or non-negated. DST is returned." ;; Value propagation. @@ -569,6 +551,96 @@ DST is returned." (mapcar #'comp-cstr-typeset srcs)))) dst) + +;;; Entry points. + +(defun comp-cstr-union-no-range (dst &rest srcs) + "Combine SRCS by union set operation setting the result in DST. +Do not propagate the range component. +DST is returned." + (apply #'comp-cstr-union-1 nil dst srcs)) + +(defun comp-cstr-union (dst &rest srcs) + "Combine SRCS by union set operation setting the result in DST. +DST is returned." + (apply #'comp-cstr-union-1 t dst srcs)) + +(defun comp-cstr-union-make (&rest srcs) + "Combine SRCS by union set operation and return a new constraint." + (apply #'comp-cstr-union (make-comp-cstr) srcs)) + +(cl-defun comp-cstr-intersection (dst &rest srcs) + "Combine SRCS by intersection set operation setting the result in DST. +DST is returned." + (with-comp-cstr-accessors + (cl-flet ((return-empty () + (setf (typeset dst) () + (valset dst) () + (range dst) () + (neg dst) nil) + (cl-return-from comp-cstr-intersection dst))) + (when-let ((res (comp-cstrs-homogeneous srcs))) + (apply #'comp-cstr-intersection-homogeneous dst srcs) + (setf (neg dst) (eq res 'neg)) + (cl-return-from comp-cstr-intersection dst)) + + ;; Some are negated and some are not + (cl-multiple-value-bind (positives negatives) (comp-split-pos-neg srcs) + (let* ((pos (apply #'comp-cstr-intersection-homogeneous + (make-comp-cstr) positives)) + (neg (apply #'comp-cstr-intersection-homogeneous + (make-comp-cstr :neg t) negatives))) + + ;; In case pos is not relevant return directly the content + ;; of neg. + (when (equal (typeset pos) '(t)) + (setf (typeset dst) (typeset neg) + (valset dst) (valset neg) + (range dst) (range neg) + (neg dst) t) + (cl-return-from comp-cstr-intersection dst)) + + (when (cl-some + (lambda (ty) + (memq ty (typeset neg))) + (typeset pos)) + (return-empty)) + + ;; Some negated types are subtypes of some non-negated one. + ;; Transform the corresponding set of types from neg to pos. + (cl-loop + for neg-type in (typeset neg) + do (cl-loop + for pos-type in (copy-sequence (typeset pos)) + when (and (not (eq neg-type pos-type)) + (comp-subtype-p neg-type pos-type)) + do (cl-loop + with found + for (type . _) in (comp-supertypes neg-type) + when found + collect type into res + when (eq type pos-type) + do (setf (typeset pos) (cl-union (typeset pos) res)) + ;; (delq neg-type (typeset neg)) + (cl-return) + when (eq type neg-type) + do (setf found t)))) + + (setf (range pos) + (if (memq 'integer (typeset pos)) + (progn + (setf (typeset pos) (delq 'integer (typeset pos))) + (comp-range-negation (range neg))) + (comp-range-intersection (range pos) + (comp-range-negation (range neg))))) + + ;; Return a non negated form. + (setf (typeset dst) (typeset pos) + (valset dst) (valset pos) + (range dst) (range pos) + (neg dst) nil))) + dst))) + (defun comp-cstr-intersection-make (&rest srcs) "Combine SRCS by intersection set operation and return a new constraint." (apply #'comp-cstr-intersection (make-comp-cstr) srcs)) diff --git a/test/lisp/emacs-lisp/comp-cstr-tests.el b/test/lisp/emacs-lisp/comp-cstr-tests.el index 392669fba0..bd141e13ad 100644 --- a/test/lisp/emacs-lisp/comp-cstr-tests.el +++ b/test/lisp/emacs-lisp/comp-cstr-tests.el @@ -155,7 +155,29 @@ ;; 57 ((or atom (not (integer 1 2))) . t) ;; 58 - ((or atom (not (member foo))) . t)) + ((or atom (not (member foo))) . t) + ;; 59 + ((and symbol (not cons)) . symbol) + ;; 60 + ((and symbol (not symbol)) . nil) + ;; 61 + ((and atom (not symbol)) . atom) + ;; 62 + ((and atom (not string)) . (or array sequence atom)) + ;; 63 Conservative + ((and symbol (not (member foo))) . symbol) + ;; 64 Conservative + ((and symbol (not (member 3))) . symbol) + ;; 65 + ((and (not (member foo)) (integer 1 10)) . (integer 1 10)) + ;; 66 + ((and (member foo) (not (integer 1 10))) . (member foo)) + ;; 67 + ((and t (not (member foo))) . (not (member foo))) + ;; 68 + ((and integer (not (integer 3 4))) . (or (integer * 2) (integer 5 *))) + ;; 69 + ((and (integer 0 20) (not (integer 5 10))) . (or (integer 0 4) (integer 11 20)))) "Alist type specifier -> expected type specifier.") (defmacro comp-cstr-synthesize-tests () commit 62869453961ec677323ed034465833304686a534 Author: Andrea Corallo Date: Sat Dec 12 10:50:32 2020 +0000 Normalize cstrs for cache hint effectiveness and test stability * lisp/emacs-lisp/comp-cstr.el (comp-normalize-valset) (comp-union-valsets, comp-intersection-valsets) (comp-normalize-typeset): New functions. (comp-union-typesets, comp-intersect-typesets) (comp-cstr-union-homogeneous-no-range, comp-cstr-union-1-no-mem): Update to return normalized results. * test/lisp/emacs-lisp/comp-cstr-tests.el (comp-cstr-typespec-tests-alist): Normalize expected type specifiers. diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el index 7a55b88477..6991c9305f 100644 --- a/lisp/emacs-lisp/comp-cstr.el +++ b/lisp/emacs-lisp/comp-cstr.el @@ -141,9 +141,34 @@ Return them as multiple value." collect cstr into positives finally (cl-return (cl-values positives negatives)))) + +;;; Value handling. + +(defun comp-normalize-valset (valset) + "Sort VALSET and return it." + (cl-sort valset (lambda (x y) + ;; We might want to use `sxhash-eql' for speed but + ;; this is safer to keep tests stable. + (< (sxhash-equal x) + (sxhash-equal y))))) + +(defun comp-union-valsets (&rest valsets) + "Union values present into VALSETS." + (comp-normalize-valset (cl-reduce #'cl-union valsets))) + +(defun comp-intersection-valsets (&rest valsets) + "Union values present into VALSETS." + (comp-normalize-valset (cl-reduce #'cl-intersection valsets))) + ;;; Type handling. +(defun comp-normalize-typeset (typeset) + "Sort TYPESET and return it." + (cl-sort typeset (lambda (x y) + (string-lessp (symbol-name x) + (symbol-name y))))) + (defun comp-supertypes (type) "Return a list of pairs (supertype . hierarchy-level) for TYPE." (cl-loop @@ -196,8 +221,8 @@ Return them as multiple value." do (setf last x) finally (when last (push last res))) - ;; TODO sort. - finally (cl-return (cl-remove-duplicates res))) + finally (cl-return (comp-normalize-typeset + (cl-remove-duplicates res)))) (comp-cstr-ctxt-union-typesets-mem comp-ctxt)))) (defun comp-intersect-typesets (&rest typesets) @@ -211,7 +236,7 @@ Return them as multiple value." ((eq st x) (list y)) ((eq st y) (list x))))) ty) - ty))) + (comp-normalize-typeset ty)))) ;;; Integer range handling @@ -324,17 +349,18 @@ All SRCS constraints must be homogeneously negated or non-negated." ;; Value propagation. (setf (comp-cstr-valset dst) - (cl-loop - with values = (mapcar #'comp-cstr-valset srcs) - ;; TODO sort. - for v in (cl-remove-duplicates (apply #'append values) - :test #'equal) - ;; We propagate only values those types are not already - ;; into typeset. - when (cl-notany (lambda (x) - (comp-subtype-p (type-of v) x)) - (comp-cstr-typeset dst)) - collect v)) + (comp-normalize-valset + (cl-loop + with values = (mapcar #'comp-cstr-valset srcs) + ;; TODO sort. + for v in (cl-remove-duplicates (apply #'append values) + :test #'equal) + ;; We propagate only values those types are not already + ;; into typeset. + when (cl-notany (lambda (x) + (comp-subtype-p (type-of v) x)) + (comp-cstr-typeset dst)) + collect v))) dst) @@ -413,7 +439,8 @@ DST is returned." ;; Value propagation. (cond ((and (valset pos) (valset neg) - (equal (cl-union (valset pos) (valset neg)) (valset pos))) + (equal (comp-union-valsets (valset pos) (valset neg)) + (valset pos))) ;; Pos is a superset of neg. (give-up)) (t diff --git a/test/lisp/emacs-lisp/comp-cstr-tests.el b/test/lisp/emacs-lisp/comp-cstr-tests.el index 0c1d27e4d1..392669fba0 100644 --- a/test/lisp/emacs-lisp/comp-cstr-tests.el +++ b/test/lisp/emacs-lisp/comp-cstr-tests.el @@ -45,23 +45,23 @@ ;; 2 ((or string array) . array) ;; 3 - ((or symbol number) . (or symbol number)) + ((or symbol number) . (or number symbol)) ;; 4 - ((or cons atom) . (or cons atom)) ;; SBCL return T + ((or cons atom) . (or atom cons)) ;; SBCL return T ;; 5 ((or integer number) . number) ;; 6 - ((or (or integer symbol) number) . (or symbol number)) + ((or (or integer symbol) number) . (or number symbol)) ;; 7 - ((or (or integer symbol) (or number list)) . (or list symbol number)) + ((or (or integer symbol) (or number list)) . (or list number symbol)) ;; 8 ((or (or integer number) nil) . number) ;; 9 ((member foo) . (member foo)) ;; 10 - ((member foo bar) . (member foo bar)) + ((member foo bar) . (member bar foo)) ;; 11 - ((or (member foo) (member bar)) . (member foo bar)) + ((or (member foo) (member bar)) . (member bar foo)) ;; 12 ((or (member foo) symbol) . symbol) ;; SBCL return (OR SYMBOL (MEMBER FOO)) ;; 13 commit a6295d31501a539f3071678e8229a014a037438e Author: Andrea Corallo Date: Thu Dec 10 18:25:51 2020 +0100 * Add `comp-split-pos-neg' function * lisp/emacs-lisp/comp-cstr.el (comp-split-pos-neg): New function. (comp-cstr-union-1-no-mem): Update to call `comp-split-pos-neg'. diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el index 9182fc3f22..7a55b88477 100644 --- a/lisp/emacs-lisp/comp-cstr.el +++ b/lisp/emacs-lisp/comp-cstr.el @@ -130,6 +130,17 @@ negated or nil othewise." ((zerop n-neg) (cl-return 'pos)) ((zerop n-pos) (cl-return 'neg))))) +(defun comp-split-pos-neg (cstrs) + "Split constraints CSTRS into non-negated and negated. +Return them as multiple value." + (cl-loop + for cstr in cstrs + if (comp-cstr-neg cstr) + collect cstr into negatives + else + collect cstr into positives + finally (cl-return (cl-values positives negatives)))) + ;;; Type handling. @@ -363,92 +374,86 @@ DST is returned." (cl-return-from comp-cstr-union-1-no-mem dst)) ;; Some are negated and some are not - (cl-loop - for cstr in srcs - if (neg cstr) - collect cstr into negatives - else - collect cstr into positives - finally - (let* ((pos (apply #'comp-cstr-union-homogeneous - (make-comp-cstr) positives)) - ;; We use neg as result as *most* of times this will be - ;; negated. - (neg (apply #'comp-cstr-union-homogeneous - (make-comp-cstr :neg t) negatives))) - ;; Type propagation. - (when (and (typeset pos) - ;; When every pos type is not a subtype of some neg ones. - (cl-every (lambda (x) - (cl-some (lambda (y) - (not (and (not (eq x y)) - (comp-subtype-p x y)))) - (typeset neg))) - (typeset pos))) - ;; This is a conservative choice, ATM we can't represent such - ;; a disjoint set of types unless we decide to add a new slot - ;; into `comp-cstr' or adopt something like - ;; `intersection-type' `union-type' in SBCL. Keep it - ;; "simple" for now. - (give-up)) - - ;; Verify disjoint condition between positive types and - ;; negative types coming from values, in case give-up. - (let ((neg-value-types (nconc (mapcar #'type-of (valset neg)) - (when (range neg) - '(integer))))) - (when (cl-some (lambda (x) - (cl-some (lambda (y) - (and (not (eq y x)) - (comp-subtype-p y x))) - neg-value-types)) - (typeset pos)) - (give-up))) - - ;; Value propagation. - (cond - ((and (valset pos) (valset neg) - (equal (cl-union (valset pos) (valset neg)) (valset pos))) - ;; Pos is a superset of neg. - (give-up)) - (t - ;; pos is a subset or eq to neg - (setf (valset neg) - (cl-nset-difference (valset neg) (valset pos))))) - - ;; Range propagation - (if (and range - (or (range pos) - (range neg))) - (if (or (valset neg) (typeset neg)) - (setf (range neg) - (if (memq 'integer (typeset neg)) - (comp-range-negation (range pos)) - (comp-range-negation - (comp-range-union (range pos) - (comp-range-negation (range neg)))))) - ;; When possibile do not return a negated cstr. - (setf (typeset dst) (typeset pos) - (valset dst) (valset pos) - (range dst) (unless (memq 'integer (typeset dst)) - (comp-range-union - (comp-range-negation (range neg)) - (range pos))) - (neg dst) nil) - (cl-return-from comp-cstr-union-1-no-mem dst)) - (setf (range neg) ())) - - (if (and (null (typeset neg)) - (null (valset neg)) - (null (range neg))) - (setf (typeset dst) (typeset pos) - (valset dst) (valset pos) - (range dst) (range pos) - (neg dst) nil) - (setf (typeset dst) (typeset neg) - (valset dst) (valset neg) - (range dst) (range neg) - (neg dst) (neg neg)))))) + (cl-multiple-value-bind (positives negatives) (comp-split-pos-neg srcs) + (let* ((pos (apply #'comp-cstr-union-homogeneous + (make-comp-cstr) positives)) + ;; We use neg as result as *most* of times this will be + ;; negated. + (neg (apply #'comp-cstr-union-homogeneous + (make-comp-cstr :neg t) negatives))) + ;; Type propagation. + (when (and (typeset pos) + ;; When every pos type is not a subtype of some neg ones. + (cl-every (lambda (x) + (cl-some (lambda (y) + (not (and (not (eq x y)) + (comp-subtype-p x y)))) + (typeset neg))) + (typeset pos))) + ;; This is a conservative choice, ATM we can't represent such + ;; a disjoint set of types unless we decide to add a new slot + ;; into `comp-cstr' or adopt something like + ;; `intersection-type' `union-type' in SBCL. Keep it + ;; "simple" for now. + (give-up)) + + ;; Verify disjoint condition between positive types and + ;; negative types coming from values, in case give-up. + (let ((neg-value-types (nconc (mapcar #'type-of (valset neg)) + (when (range neg) + '(integer))))) + (when (cl-some (lambda (x) + (cl-some (lambda (y) + (and (not (eq y x)) + (comp-subtype-p y x))) + neg-value-types)) + (typeset pos)) + (give-up))) + + ;; Value propagation. + (cond + ((and (valset pos) (valset neg) + (equal (cl-union (valset pos) (valset neg)) (valset pos))) + ;; Pos is a superset of neg. + (give-up)) + (t + ;; pos is a subset or eq to neg + (setf (valset neg) + (cl-nset-difference (valset neg) (valset pos))))) + + ;; Range propagation + (if (and range + (or (range pos) + (range neg))) + (if (or (valset neg) (typeset neg)) + (setf (range neg) + (if (memq 'integer (typeset neg)) + (comp-range-negation (range pos)) + (comp-range-negation + (comp-range-union (range pos) + (comp-range-negation (range neg)))))) + ;; When possibile do not return a negated cstr. + (setf (typeset dst) (typeset pos) + (valset dst) (valset pos) + (range dst) (unless (memq 'integer (typeset dst)) + (comp-range-union + (comp-range-negation (range neg)) + (range pos))) + (neg dst) nil) + (cl-return-from comp-cstr-union-1-no-mem dst)) + (setf (range neg) ())) + + (if (and (null (typeset neg)) + (null (valset neg)) + (null (range neg))) + (setf (typeset dst) (typeset pos) + (valset dst) (valset pos) + (range dst) (range pos) + (neg dst) nil) + (setf (typeset dst) (typeset neg) + (valset dst) (valset neg) + (range dst) (range neg) + (neg dst) (neg neg)))))) dst)) (defun comp-cstr-union-1 (range dst &rest srcs) commit 725c7e1416872f199bf544486fc20243a5ada2db Author: Andrea Corallo Date: Mon Dec 7 21:41:49 2020 +0100 * Enumerate type specifier tests to ease debugging * test/lisp/emacs-lisp/comp-cstr-tests.el (comp-cstr-typespec-tests-alist): Enumerate tests. Acked-by: Andrea Corallo diff --git a/test/lisp/emacs-lisp/comp-cstr-tests.el b/test/lisp/emacs-lisp/comp-cstr-tests.el index 6e1d0d463e..0c1d27e4d1 100644 --- a/test/lisp/emacs-lisp/comp-cstr-tests.el +++ b/test/lisp/emacs-lisp/comp-cstr-tests.el @@ -40,67 +40,121 @@ ',expected-type-spec)))) (defconst comp-cstr-typespec-tests-alist - `((symbol . symbol) + `(;; 1 + (symbol . symbol) + ;; 2 ((or string array) . array) + ;; 3 ((or symbol number) . (or symbol number)) + ;; 4 ((or cons atom) . (or cons atom)) ;; SBCL return T + ;; 5 ((or integer number) . number) + ;; 6 ((or (or integer symbol) number) . (or symbol number)) + ;; 7 ((or (or integer symbol) (or number list)) . (or list symbol number)) + ;; 8 ((or (or integer number) nil) . number) + ;; 9 ((member foo) . (member foo)) + ;; 10 ((member foo bar) . (member foo bar)) + ;; 11 ((or (member foo) (member bar)) . (member foo bar)) + ;; 12 ((or (member foo) symbol) . symbol) ;; SBCL return (OR SYMBOL (MEMBER FOO)) + ;; 13 ((or (member foo) number) . (or (member foo) number)) + ;; 14 ((or (integer 1 3) number) . number) + ;; 15 (integer . integer) + ;; 16 ((integer 1 2) . (integer 1 2)) + ;; 17 ((or (integer -1 0) (integer 3 4)) . (or (integer -1 0) (integer 3 4))) + ;; 18 ((or (integer -1 2) (integer 3 4)) . (integer -1 4)) + ;; 19 ((or (integer -1 3) (integer 3 4)) . (integer -1 4)) + ;; 20 ((or (integer -1 4) (integer 3 4)) . (integer -1 4)) + ;; 21 ((or (integer -1 5) (integer 3 4)) . (integer -1 5)) + ;; 22 ((or (integer -1 *) (integer 3 4)) . (integer -1 *)) + ;; 23 ((or (integer -1 2) (integer * 4)) . (integer * 4)) + ;; 24 ((and string array) . string) + ;; 25 ((and cons atom) . nil) + ;; 26 ((and (member foo) (member foo bar baz)) . (member foo)) + ;; 27 ((and (member foo) (member bar)) . nil) + ;; 28 ((and (member foo) symbol) . (member foo)) + ;; 29 ((and (member foo) string) . nil) + ;; 30 ((and (member foo) (integer 1 2)) . nil) + ;; 31 ((and (member 1 2) (member 3 2)) . (member 2)) + ;; 32 ((and number (integer 1 2)) . number) + ;; 33 ((and integer (integer 1 2)) . integer) + ;; 34 ((and (integer -1 0) (integer 3 5)) . nil) + ;; 35 ((and (integer -1 2) (integer 3 5)) . nil) + ;; 36 ((and (integer -1 3) (integer 3 5)) . (integer 3 3)) + ;; 37 ((and (integer -1 4) (integer 3 5)) . (integer 3 4)) + ;; 38 ((and (integer -1 5) nil) . nil) + ;; 39 ((not symbol) . (not symbol)) + ;; 40 ((or (member foo) (not (member foo bar))) . (not (member bar))) + ;; 41 ((or (member foo bar) (not (member foo))) . t) - ;; Intentionally conservative, see `comp-cstr-union-1-no-mem'. + ;; 42 Intentionally conservative, see `comp-cstr-union-1-no-mem'. ((or symbol (not sequence)) . t) + ;; 43 ((or symbol (not symbol)) . t) - ;; Conservative. + ;; 44 Conservative. ((or symbol (not sequence)) . t) + ;; 45 ((or vector (not sequence)) . (not sequence)) + ;; 46 ((or (integer 1 10) (not (integer * 5))) . (integer 1 *)) + ;; 47 ((or symbol (integer 1 10) (not (integer * 5))) . (or symbol (integer 1 *))) + ;; 48 ((or (not symbol) (integer 1 10) (not (integer * 5))) . (not (or symbol (integer * 0)))) + ;; 49 ((or symbol (not (member foo))) . (not (member foo))) + ;; 50 ((or (not symbol) (not (member foo))) . (not symbol)) - ;; Conservative. + ;; 51 Conservative. ((or (not (member foo)) string) . (not (member foo))) - ;; Conservative. + ;; 52 Conservative. ((or (member foo) (not string)) . (not string)) + ;; 53 ((or (not (integer 1 2)) integer) . integer) + ;; 54 ((or (not (integer 1 2)) (not integer)) . (not integer)) + ;; 55 ((or (integer 1 2) (not integer)) . (not (or integer (integer * 0) (integer 3 *)))) + ;; 56 ((or number (not (integer 1 2))) . t) + ;; 57 ((or atom (not (integer 1 2))) . t) + ;; 58 ((or atom (not (member foo))) . t)) "Alist type specifier -> expected type specifier.") @@ -108,7 +162,7 @@ "Generate all tests from `comp-cstr-typespec-tests-alist'." `(progn ,@(cl-loop - for i from 0 + for i from 1 for (ts . exp-ts) in comp-cstr-typespec-tests-alist append (list (comp-cstr-typespec-test i ts exp-ts))))) commit 73b5e40750afa19299435f980a959fea57f9641b Author: Andrea Corallo Date: Mon Dec 7 21:33:11 2020 +0100 * Code rework add `comp-cstrs-homogeneous' * lisp/emacs-lisp/comp-cstr.el (comp-cstrs-homogeneous): New function. (comp-cstr-union-1-no-mem): Make use of. diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el index 892a8d349d..9182fc3f22 100644 --- a/lisp/emacs-lisp/comp-cstr.el +++ b/lisp/emacs-lisp/comp-cstr.el @@ -115,6 +115,21 @@ Integer values are handled in the `range' slot.") :range (copy-tree (range cstr)) :neg (copy-tree (neg cstr))))) +(defun comp-cstrs-homogeneous (cstrs) + "Check if constraints CSTRS are all homogeneously negated or non-negated. +Return `pos' if they are all positive, `neg' if they are all +negated or nil othewise." + (cl-loop + for cstr in cstrs + unless (comp-cstr-neg cstr) + count t into n-pos + else + count t into n-neg + finally + (cond + ((zerop n-neg) (cl-return 'pos)) + ((zerop n-pos) (cl-return 'neg))))) + ;;; Type handling. @@ -342,18 +357,10 @@ DST is returned." ;; Check first if we are in the simple case of all input non-negate ;; or negated so we don't have to cons. - (cl-loop - for cstr in srcs - unless (neg cstr) - count t into n-pos - else - count t into n-neg - finally - (when (or (zerop n-pos) (zerop n-neg)) - (apply #'comp-cstr-union-homogeneous dst srcs) - (when (zerop n-pos) - (setf (neg dst) t)) - (cl-return-from comp-cstr-union-1-no-mem dst))) + (when-let ((res (comp-cstrs-homogeneous srcs))) + (apply #'comp-cstr-union-homogeneous dst srcs) + (setf (neg dst) (eq res 'neg)) + (cl-return-from comp-cstr-union-1-no-mem dst)) ;; Some are negated and some are not (cl-loop commit c39fad909cf9720626d310618cfdeae2ccf330ba Author: Andrea Corallo Date: Sat Dec 12 16:26:17 2020 +0100 * test/src/comp-tests.el (comp-tests-bootstrap): Temp fix bootstrap test. diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index c2af52e4ca..e73fc652d6 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -56,8 +56,9 @@ "Compile the compiler and load it to compile it-self. Check that the resulting binaries do not differ." :tags '(:expensive-test :nativecomp) - (let* ((comp-src (concat comp-test-directory - "../../lisp/emacs-lisp/comp.el")) + (let* ((byte-native-for-bootstrap t) ; FIXME HACK + (comp-src (concat comp-test-directory + "../../lisp/emacs-lisp/comp.el")) (comp1-src (make-temp-file "stage1-" nil ".el")) (comp2-src (make-temp-file "stage2-" nil ".el")) ;; Can't use debug symbols. commit 0474fda62d79cb7eb250f34f19773c87f283c665 Merge: be907b0ba8 4afef614cd Author: Andrea Corallo Date: Sat Dec 12 15:31:33 2020 +0100 Merge remote-tracking branch 'savannah/master' into HEAD commit be907b0ba82c2a65e0468d50653cae8a7cf5f16b Author: Andrea Corallo Date: Mon Dec 7 12:22:48 2020 +0100 * Spawn a sub-process for running GCC also in batch mode (bug#45056) * lisp/emacs-lisp/comp.el (comp-async-compilation): New variable. (comp-final): Always run the C side of the compilation as a sub-process unless during bootstrap or async compilation. (comp-run-async-workers): Set `comp-async-compilation'. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 13f9beb5f9..339fff7aa1 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2805,11 +2805,18 @@ Prepare every function for final compilation and drive the C back-end." (and (comp--release-ctxt) compile-result)))) +(defvar comp-async-compilation nil + "Non-nil while executing an asyncronous native compilation.") + (defun comp-final (_) "Final pass driving the C back-end for code emission." (maphash #'comp-ret-type-spec (comp-ctxt-funcs-h comp-ctxt)) (unless comp-dry-run - (if noninteractive + ;; Always run the C side of the compilation as a sub-process + ;; unless during bootstrap or async compilation (bug#45056). GCC + ;; leaks memory but also interfere with the ability of Emacs to + ;; detect when a sub-process completes (TODO understand why). + (if (or byte-native-for-bootstrap comp-async-compilation) (comp-final1) ;; Call comp-final1 in a child process. (let* ((output (comp-ctxt-output comp-ctxt)) @@ -3073,6 +3080,7 @@ display a message." (setf comp-speed ,comp-speed comp-debug ,comp-debug comp-verbose ,comp-verbose + comp-async-compilation t comp-eln-load-path ',comp-eln-load-path comp-native-driver-options ',comp-native-driver-options commit 715a1ca1744f9a5918376bf7662c81302f0b20c0 Merge: 27f666e111 40e11743ca Author: Andrea Corallo Date: Sun Dec 6 18:07:27 2020 +0100 Merge remote-tracking branch 'savannah/master' into HEAD commit 27f666e111a34d64de81a214024e1e30928b416e Author: Andrea Corallo Date: Sun Dec 6 18:01:28 2020 +0100 * Unify common fallback exit point in `comp-cstr-union-1-no-mem'. * lisp/emacs-lisp/comp-cstr.el (comp-cstr-union-1-no-mem): Define a local function `give-up' as a common fall-back exit point. diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el index d4e47cf302..892a8d349d 100644 --- a/lisp/emacs-lisp/comp-cstr.el +++ b/lisp/emacs-lisp/comp-cstr.el @@ -333,121 +333,115 @@ Do range propagation when RANGE is non-nil. Non memoized version of `comp-cstr-union-1'. DST is returned." (with-comp-cstr-accessors - ;; Check first if we are in the simple case of all input non-negate - ;; or negated so we don't have to cons. - (cl-loop - for cstr in srcs - unless (neg cstr) - count t into n-pos - else - count t into n-neg - finally - (when (or (zerop n-pos) (zerop n-neg)) - (apply #'comp-cstr-union-homogeneous dst srcs) - (when (zerop n-pos) - (setf (neg dst) t)) - (cl-return-from comp-cstr-union-1-no-mem dst))) - - ;; Some are negated and some are not - (cl-loop - for cstr in srcs - if (neg cstr) - collect cstr into negatives - else - collect cstr into positives - finally - (let* ((pos (apply #'comp-cstr-union-homogeneous - (make-comp-cstr) positives)) - ;; We use neg as result as *most* of times this will be - ;; negated. - (neg (apply #'comp-cstr-union-homogeneous - (make-comp-cstr :neg t) negatives))) - - ;; Type propagation. - (when (and (typeset pos) - ;; When every pos type is not a subtype of some neg ones. - (cl-every (lambda (x) - (cl-some (lambda (y) - (not (and (not (eq x y)) - (comp-subtype-p x y)))) - (typeset neg))) - (typeset pos))) - ;; This is a conservative choice, ATM we can't represent such - ;; a disjoint set of types unless we decide to add a new slot - ;; into `comp-cstr' or adopt something like - ;; `intersection-type' `union-type' in SBCL. Keep it - ;; "simple" for now. - (setf (typeset dst) '(t) - (valset dst) () - (range dst) () - (neg dst) nil) - (cl-return-from comp-cstr-union-1-no-mem dst)) - - ;; Verify disjoint condition between positive types and - ;; negative types coming from values, in case give-up. - (let ((neg-value-types (nconc (mapcar #'type-of (valset neg)) - (when (range neg) - '(integer))))) - (when (cl-some (lambda (x) - (cl-some (lambda (y) - (and (not (eq y x)) - (comp-subtype-p y x))) - neg-value-types)) - (typeset pos)) - (setf (typeset dst) '(t) - (valset dst) () - (range dst) () - (neg dst) nil) - (cl-return-from comp-cstr-union-1-no-mem dst))) - - ;; Value propagation. - (cond - ((and (valset pos) (valset neg) - (equal (cl-union (valset pos) (valset neg)) (valset pos))) - ;; Pos is a superset of neg. - (setf (typeset dst) '(t) - (valset dst) () - (range dst) () - (neg dst) nil) - (cl-return-from comp-cstr-union-1-no-mem dst)) - (t - ;; pos is a subset or eq to neg - (setf (valset neg) - (cl-nset-difference (valset neg) (valset pos))))) - - ;; Range propagation - (if (and range - (or (range pos) - (range neg))) - (if (or (valset neg) (typeset neg)) - (setf (range neg) - (if (memq 'integer (typeset neg)) - (comp-range-negation (range pos)) - (comp-range-negation - (comp-range-union (range pos) - (comp-range-negation (range neg)))))) - ;; When possibile do not return a negated cstr. + (cl-flet ((give-up () + (setf (typeset dst) '(t) + (valset dst) () + (range dst) () + (neg dst) nil) + (cl-return-from comp-cstr-union-1-no-mem dst))) + + ;; Check first if we are in the simple case of all input non-negate + ;; or negated so we don't have to cons. + (cl-loop + for cstr in srcs + unless (neg cstr) + count t into n-pos + else + count t into n-neg + finally + (when (or (zerop n-pos) (zerop n-neg)) + (apply #'comp-cstr-union-homogeneous dst srcs) + (when (zerop n-pos) + (setf (neg dst) t)) + (cl-return-from comp-cstr-union-1-no-mem dst))) + + ;; Some are negated and some are not + (cl-loop + for cstr in srcs + if (neg cstr) + collect cstr into negatives + else + collect cstr into positives + finally + (let* ((pos (apply #'comp-cstr-union-homogeneous + (make-comp-cstr) positives)) + ;; We use neg as result as *most* of times this will be + ;; negated. + (neg (apply #'comp-cstr-union-homogeneous + (make-comp-cstr :neg t) negatives))) + ;; Type propagation. + (when (and (typeset pos) + ;; When every pos type is not a subtype of some neg ones. + (cl-every (lambda (x) + (cl-some (lambda (y) + (not (and (not (eq x y)) + (comp-subtype-p x y)))) + (typeset neg))) + (typeset pos))) + ;; This is a conservative choice, ATM we can't represent such + ;; a disjoint set of types unless we decide to add a new slot + ;; into `comp-cstr' or adopt something like + ;; `intersection-type' `union-type' in SBCL. Keep it + ;; "simple" for now. + (give-up)) + + ;; Verify disjoint condition between positive types and + ;; negative types coming from values, in case give-up. + (let ((neg-value-types (nconc (mapcar #'type-of (valset neg)) + (when (range neg) + '(integer))))) + (when (cl-some (lambda (x) + (cl-some (lambda (y) + (and (not (eq y x)) + (comp-subtype-p y x))) + neg-value-types)) + (typeset pos)) + (give-up))) + + ;; Value propagation. + (cond + ((and (valset pos) (valset neg) + (equal (cl-union (valset pos) (valset neg)) (valset pos))) + ;; Pos is a superset of neg. + (give-up)) + (t + ;; pos is a subset or eq to neg + (setf (valset neg) + (cl-nset-difference (valset neg) (valset pos))))) + + ;; Range propagation + (if (and range + (or (range pos) + (range neg))) + (if (or (valset neg) (typeset neg)) + (setf (range neg) + (if (memq 'integer (typeset neg)) + (comp-range-negation (range pos)) + (comp-range-negation + (comp-range-union (range pos) + (comp-range-negation (range neg)))))) + ;; When possibile do not return a negated cstr. + (setf (typeset dst) (typeset pos) + (valset dst) (valset pos) + (range dst) (unless (memq 'integer (typeset dst)) + (comp-range-union + (comp-range-negation (range neg)) + (range pos))) + (neg dst) nil) + (cl-return-from comp-cstr-union-1-no-mem dst)) + (setf (range neg) ())) + + (if (and (null (typeset neg)) + (null (valset neg)) + (null (range neg))) (setf (typeset dst) (typeset pos) (valset dst) (valset pos) - (range dst) (unless (memq 'integer (typeset dst)) - (comp-range-union - (comp-range-negation (range neg)) - (range pos))) + (range dst) (range pos) (neg dst) nil) - (cl-return-from comp-cstr-union-1-no-mem dst)) - (setf (range neg) ())) - - (if (and (null (typeset neg)) - (null (valset neg)) - (null (range neg))) - (setf (typeset dst) (typeset pos) - (valset dst) (valset pos) - (range dst) (range pos) - (neg dst) nil) - (setf (typeset dst) (typeset neg) - (valset dst) (valset neg) - (range dst) (range neg) - (neg dst) (neg neg))))) + (setf (typeset dst) (typeset neg) + (valset dst) (valset neg) + (range dst) (range neg) + (neg dst) (neg neg)))))) dst)) (defun comp-cstr-union-1 (range dst &rest srcs) commit ac40a60696322cd92f37fcddda97ae9c00226bf8 Author: Andrea Corallo Date: Sat Dec 5 23:42:25 2020 +0100 Couple of `comp-cstr-union-1-no-mem' improvements for mixed neg pos union * lisp/emacs-lisp/comp-cstr.el (comp-cstr-union-1-no-mem): Generalize disjoint pos types vs neg values conditions. (comp-cstr-union-1-no-mem): Do not propagate ranges when we are already returning integer as generic type. * test/lisp/emacs-lisp/comp-cstr-tests.el (comp-cstr-typespec-tests-alist): Add corresponding tests. diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el index bb63ff3e96..d4e47cf302 100644 --- a/lisp/emacs-lisp/comp-cstr.el +++ b/lisp/emacs-lisp/comp-cstr.el @@ -383,6 +383,23 @@ DST is returned." (neg dst) nil) (cl-return-from comp-cstr-union-1-no-mem dst)) + ;; Verify disjoint condition between positive types and + ;; negative types coming from values, in case give-up. + (let ((neg-value-types (nconc (mapcar #'type-of (valset neg)) + (when (range neg) + '(integer))))) + (when (cl-some (lambda (x) + (cl-some (lambda (y) + (and (not (eq y x)) + (comp-subtype-p y x))) + neg-value-types)) + (typeset pos)) + (setf (typeset dst) '(t) + (valset dst) () + (range dst) () + (neg dst) nil) + (cl-return-from comp-cstr-union-1-no-mem dst))) + ;; Value propagation. (cond ((and (valset pos) (valset neg) @@ -401,12 +418,8 @@ DST is returned." ;; Range propagation (if (and range (or (range pos) - (range neg)) - (cl-notany (lambda (x) - (comp-subtype-p 'integer x)) - (typeset pos))) - (if (or (valset neg) - (typeset neg)) + (range neg))) + (if (or (valset neg) (typeset neg)) (setf (range neg) (if (memq 'integer (typeset neg)) (comp-range-negation (range pos)) @@ -416,9 +429,10 @@ DST is returned." ;; When possibile do not return a negated cstr. (setf (typeset dst) (typeset pos) (valset dst) (valset pos) - (range dst) (comp-range-union - (comp-range-negation (range neg)) - (range pos)) + (range dst) (unless (memq 'integer (typeset dst)) + (comp-range-union + (comp-range-negation (range neg)) + (range pos))) (neg dst) nil) (cl-return-from comp-cstr-union-1-no-mem dst)) (setf (range neg) ())) diff --git a/test/lisp/emacs-lisp/comp-cstr-tests.el b/test/lisp/emacs-lisp/comp-cstr-tests.el index bc772fcb0d..6e1d0d463e 100644 --- a/test/lisp/emacs-lisp/comp-cstr-tests.el +++ b/test/lisp/emacs-lisp/comp-cstr-tests.el @@ -81,7 +81,7 @@ ((not symbol) . (not symbol)) ((or (member foo) (not (member foo bar))) . (not (member bar))) ((or (member foo bar) (not (member foo))) . t) - ;; Intentionally conservative, see `comp-cstr-union'. + ;; Intentionally conservative, see `comp-cstr-union-1-no-mem'. ((or symbol (not sequence)) . t) ((or symbol (not symbol)) . t) ;; Conservative. @@ -98,7 +98,10 @@ ((or (member foo) (not string)) . (not string)) ((or (not (integer 1 2)) integer) . integer) ((or (not (integer 1 2)) (not integer)) . (not integer)) - ((or (integer 1 2) (not integer)) . (not (or integer (integer * 0) (integer 3 *))))) + ((or (integer 1 2) (not integer)) . (not (or integer (integer * 0) (integer 3 *)))) + ((or number (not (integer 1 2))) . t) + ((or atom (not (integer 1 2))) . t) + ((or atom (not (member foo))) . t)) "Alist type specifier -> expected type specifier.") (defmacro comp-cstr-synthesize-tests () commit 09ec39e35213f92ce297dfed7a42af56b5e2b693 Author: Andrea Corallo Date: Sat Dec 5 19:36:00 2020 +0100 * Memoize `comp-cstr-union-1' * lisp/emacs-lisp/comp-cstr.el (comp-cstr): Do not synthesize the copier. (comp-cstr-ctxt): Add `union-1-mem-no-range' `union-1-mem-range' slots. (comp-cstr-copy): New function. (comp-cstr-union-1-no-mem): Rename from `comp-cstr-union-1'. (comp-cstr-union-1): New function. diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el index c0e6a57f4d..bb63ff3e96 100644 --- a/lisp/emacs-lisp/comp-cstr.el +++ b/lisp/emacs-lisp/comp-cstr.el @@ -57,7 +57,8 @@ (:constructor comp-irange-to-cstr (irange &aux (range (list irange)) - (typeset ())))) + (typeset ()))) + (:copier nil)) "Internal representation of a type/value constraint." (typeset '(t) :type list :documentation "List of possible types the mvar can assume. @@ -84,7 +85,13 @@ Integer values are handled in the `range' slot.") ;; TODO we should be able to just cons hash this. (common-supertype-mem (make-hash-table :test #'equal) :type hash-table :documentation "Serve memoization for -`comp-common-supertype'.")) +`comp-common-supertype'.") + (union-1-mem-no-range (make-hash-table :test #'equal) :type hash-table + :documentation "Serve memoization for +`comp-cstr-union-1'.") + (union-1-mem-range (make-hash-table :test #'equal) :type hash-table + :documentation "Serve memoization for +`comp-cstr-union-1'.")) (defmacro with-comp-cstr-accessors (&rest body) "Define some quick accessor to reduce code vergosity in BODY." @@ -100,6 +107,14 @@ Integer values are handled in the `range' slot.") `(comp-cstr-neg ,@x))) ,@body)) +(defun comp-cstr-copy (cstr) + "Return a deep copy of CSTR." + (with-comp-cstr-accessors + (make-comp-cstr :typeset (copy-tree (typeset cstr)) + :valset (copy-tree (valset cstr)) + :range (copy-tree (range cstr)) + :neg (copy-tree (neg cstr))))) + ;;; Type handling. @@ -312,9 +327,10 @@ DST is returned." (mapcar #'comp-cstr-range srcs)))) dst) -(cl-defun comp-cstr-union-1 (range dst &rest srcs) +(cl-defun comp-cstr-union-1-no-mem (range dst &rest srcs) "Combine SRCS by union set operation setting the result in DST. Do range propagation when RANGE is non-nil. +Non memoized version of `comp-cstr-union-1'. DST is returned." (with-comp-cstr-accessors ;; Check first if we are in the simple case of all input non-negate @@ -330,7 +346,7 @@ DST is returned." (apply #'comp-cstr-union-homogeneous dst srcs) (when (zerop n-pos) (setf (neg dst) t)) - (cl-return-from comp-cstr-union-1 dst))) + (cl-return-from comp-cstr-union-1-no-mem dst))) ;; Some are negated and some are not (cl-loop @@ -365,7 +381,7 @@ DST is returned." (valset dst) () (range dst) () (neg dst) nil) - (cl-return-from comp-cstr-union-1 dst)) + (cl-return-from comp-cstr-union-1-no-mem dst)) ;; Value propagation. (cond @@ -376,7 +392,7 @@ DST is returned." (valset dst) () (range dst) () (neg dst) nil) - (cl-return-from comp-cstr-union-1 dst)) + (cl-return-from comp-cstr-union-1-no-mem dst)) (t ;; pos is a subset or eq to neg (setf (valset neg) @@ -404,7 +420,7 @@ DST is returned." (comp-range-negation (range neg)) (range pos)) (neg dst) nil) - (cl-return-from comp-cstr-union-1 dst)) + (cl-return-from comp-cstr-union-1-no-mem dst)) (setf (range neg) ())) (if (and (null (typeset neg)) @@ -420,6 +436,25 @@ DST is returned." (neg dst) (neg neg))))) dst)) +(defun comp-cstr-union-1 (range dst &rest srcs) + "Combine SRCS by union set operation setting the result in DST. +Do range propagation when RANGE is non-nil. +DST is returned." + (let ((mem-h (if range + (comp-cstr-ctxt-union-1-mem-range comp-ctxt) + (comp-cstr-ctxt-union-1-mem-no-range comp-ctxt)))) + (with-comp-cstr-accessors + (if-let ((mem-res (gethash srcs mem-h))) + (progn + (setf (typeset dst) (typeset mem-res) + (valset dst) (valset mem-res) + (range dst) (range mem-res) + (neg dst) (neg mem-res)) + mem-res) + (let ((res (apply #'comp-cstr-union-1-no-mem range dst srcs))) + (puthash srcs (comp-cstr-copy res) mem-h) + res))))) + ;;; Entry points. commit 2eb41ec137839d06a856e1f910dfa5d2fa97e451 Author: Andrea Corallo Date: Wed Dec 2 23:51:19 2020 +0100 More improvements to `comp-cstr-union-1' for mixed positive/negative cases * lisp/emacs-lisp/comp-cstr.el (comp-cstr-union-1): Better handle mixed positive/negated cases. * test/lisp/emacs-lisp/comp-cstr-tests.el (comp-cstr-typespec-tests-alist): Add a number of tests. diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el index 5a45294ed8..c0e6a57f4d 100644 --- a/lisp/emacs-lisp/comp-cstr.el +++ b/lisp/emacs-lisp/comp-cstr.el @@ -340,22 +340,27 @@ DST is returned." else collect cstr into positives finally - (let* ((pos (apply #'comp-cstr-union-homogeneous (make-comp-cstr) positives)) - (neg (apply #'comp-cstr-union-homogeneous (make-comp-cstr) negatives))) + (let* ((pos (apply #'comp-cstr-union-homogeneous + (make-comp-cstr) positives)) + ;; We use neg as result as *most* of times this will be + ;; negated. + (neg (apply #'comp-cstr-union-homogeneous + (make-comp-cstr :neg t) negatives))) ;; Type propagation. (when (and (typeset pos) - ;; When some pos type is not a subtype of any neg ones. + ;; When every pos type is not a subtype of some neg ones. (cl-every (lambda (x) (cl-some (lambda (y) - (not (comp-subtype-p x y))) + (not (and (not (eq x y)) + (comp-subtype-p x y)))) (typeset neg))) (typeset pos))) - ;; This is a conservative choice, ATM we can't represent such a - ;; disjoint set of types unless we decide to add a new slot - ;; into `comp-cstr' list them all. This probably wouldn't - ;; work for the future when we'll support also non-builtin - ;; types. + ;; This is a conservative choice, ATM we can't represent such + ;; a disjoint set of types unless we decide to add a new slot + ;; into `comp-cstr' or adopt something like + ;; `intersection-type' `union-type' in SBCL. Keep it + ;; "simple" for now. (setf (typeset dst) '(t) (valset dst) () (range dst) () @@ -363,41 +368,56 @@ DST is returned." (cl-return-from comp-cstr-union-1 dst)) ;; Value propagation. - (setf (valset neg) - (cl-nset-difference (valset neg) (valset pos))) + (cond + ((and (valset pos) (valset neg) + (equal (cl-union (valset pos) (valset neg)) (valset pos))) + ;; Pos is a superset of neg. + (setf (typeset dst) '(t) + (valset dst) () + (range dst) () + (neg dst) nil) + (cl-return-from comp-cstr-union-1 dst)) + (t + ;; pos is a subset or eq to neg + (setf (valset neg) + (cl-nset-difference (valset neg) (valset pos))))) ;; Range propagation - (when (and range - (or (range pos) - (range neg)) - (cl-notany (lambda (x) - (comp-subtype-p 'integer x)) - (typeset pos))) - (if (or (valset neg) - (typeset neg)) - (setf (range neg) - (comp-range-union (comp-range-negation (range pos)) - (range neg))) - ;; When possibile do not return a negated cstr. - (setf (typeset dst) () - (valset dst) () - (range dst) (comp-range-union - (comp-range-negation (range neg)) - (range pos)) - (neg dst) nil) - (cl-return-from comp-cstr-union-1 dst))) + (if (and range + (or (range pos) + (range neg)) + (cl-notany (lambda (x) + (comp-subtype-p 'integer x)) + (typeset pos))) + (if (or (valset neg) + (typeset neg)) + (setf (range neg) + (if (memq 'integer (typeset neg)) + (comp-range-negation (range pos)) + (comp-range-negation + (comp-range-union (range pos) + (comp-range-negation (range neg)))))) + ;; When possibile do not return a negated cstr. + (setf (typeset dst) (typeset pos) + (valset dst) (valset pos) + (range dst) (comp-range-union + (comp-range-negation (range neg)) + (range pos)) + (neg dst) nil) + (cl-return-from comp-cstr-union-1 dst)) + (setf (range neg) ())) (if (and (null (typeset neg)) (null (valset neg)) (null (range neg))) - (setf (typeset dst) '(t) - (valset dst) () - (range dst) () + (setf (typeset dst) (typeset pos) + (valset dst) (valset pos) + (range dst) (range pos) (neg dst) nil) (setf (typeset dst) (typeset neg) (valset dst) (valset neg) (range dst) (range neg) - (neg dst) t)))) + (neg dst) (neg neg))))) dst)) diff --git a/test/lisp/emacs-lisp/comp-cstr-tests.el b/test/lisp/emacs-lisp/comp-cstr-tests.el index 0b10b7f80a..bc772fcb0d 100644 --- a/test/lisp/emacs-lisp/comp-cstr-tests.el +++ b/test/lisp/emacs-lisp/comp-cstr-tests.el @@ -83,11 +83,22 @@ ((or (member foo bar) (not (member foo))) . t) ;; Intentionally conservative, see `comp-cstr-union'. ((or symbol (not sequence)) . t) + ((or symbol (not symbol)) . t) + ;; Conservative. + ((or symbol (not sequence)) . t) ((or vector (not sequence)) . (not sequence)) ((or (integer 1 10) (not (integer * 5))) . (integer 1 *)) - ((or symbol (integer 1 10) (not (integer * 5))) . (integer 1 *)) + ((or symbol (integer 1 10) (not (integer * 5))) . (or symbol (integer 1 *))) + ((or (not symbol) (integer 1 10) (not (integer * 5))) . (not (or symbol (integer * 0)))) ((or symbol (not (member foo))) . (not (member foo))) - ((or (not symbol) (not (member foo))) . (not symbol))) + ((or (not symbol) (not (member foo))) . (not symbol)) + ;; Conservative. + ((or (not (member foo)) string) . (not (member foo))) + ;; Conservative. + ((or (member foo) (not string)) . (not string)) + ((or (not (integer 1 2)) integer) . integer) + ((or (not (integer 1 2)) (not integer)) . (not integer)) + ((or (integer 1 2) (not integer)) . (not (or integer (integer * 0) (integer 3 *))))) "Alist type specifier -> expected type specifier.") (defmacro comp-cstr-synthesize-tests () commit f923de6853a4958f1e50afef683f95ea5fcd31a1 Author: Andrea Corallo Date: Sat Dec 5 17:59:00 2020 +0100 * Fix `comp-cstr-to-type-spec' * lisp/emacs-lisp/comp-cstr.el (comp-star-or-num-p): New predicate. (comp-type-spec-to-cstr): Make use of. (comp-cstr-to-type-spec): Output correctly type specifiers as (not (or integer ... diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el index 3aad3dc2c2..5a45294ed8 100644 --- a/lisp/emacs-lisp/comp-cstr.el +++ b/lisp/emacs-lisp/comp-cstr.el @@ -175,6 +175,9 @@ Integer values are handled in the `range' slot.") ;;; Integer range handling +(defsubst comp-star-or-num-p (x) + (or (numberp x) (eq '* x))) + (defsubst comp-range-1+ (x) (if (symbolp x) x @@ -484,46 +487,44 @@ DST is returned." (defun comp-type-spec-to-cstr (type-spec &optional fn) "Convert a type specifier TYPE-SPEC into a `comp-cstr'. FN non-nil indicates we are parsing a function lambda list." - (cl-flet ((star-or-num (x) - (or (numberp x) (eq '* x)))) - (pcase type-spec - ((and (or '&optional '&rest) x) - (if fn - x - (error "Invalid `%s` in type specifier" x))) - ('fixnum - (comp-irange-to-cstr `(,most-negative-fixnum . ,most-positive-fixnum))) - ('boolean - (comp-type-spec-to-cstr '(member t nil))) - ('null (comp-value-to-cstr nil)) - ((pred atom) - (comp-type-to-cstr type-spec)) - (`(or . ,rest) - (apply #'comp-cstr-union-make - (mapcar #'comp-type-spec-to-cstr rest))) - (`(and . ,rest) - (apply #'comp-cstr-intersection-make - (mapcar #'comp-type-spec-to-cstr rest))) - (`(not ,cstr) - (comp-cstr-negation-make (comp-type-spec-to-cstr cstr))) - (`(integer ,(and (pred integerp) l) ,(and (pred integerp) h)) - (comp-irange-to-cstr `(,l . ,h))) - (`(integer * ,(and (pred integerp) h)) - (comp-irange-to-cstr `(- . ,h))) - (`(integer ,(and (pred integerp) l) *) - (comp-irange-to-cstr `(,l . +))) - (`(float ,(pred star-or-num) ,(pred star-or-num)) - ;; No float range support :/ - (comp-type-to-cstr 'float)) - (`(member . ,rest) - (apply #'comp-cstr-union-make (mapcar #'comp-value-to-cstr rest))) - (`(function ,args ,ret) - (make-comp-cstr-f - :args (mapcar (lambda (x) - (comp-type-spec-to-cstr x t)) - args) - :ret (comp-type-spec-to-cstr ret))) - (_ (error "Invalid type specifier"))))) + (pcase type-spec + ((and (or '&optional '&rest) x) + (if fn + x + (error "Invalid `%s` in type specifier" x))) + ('fixnum + (comp-irange-to-cstr `(,most-negative-fixnum . ,most-positive-fixnum))) + ('boolean + (comp-type-spec-to-cstr '(member t nil))) + ('null (comp-value-to-cstr nil)) + ((pred atom) + (comp-type-to-cstr type-spec)) + (`(or . ,rest) + (apply #'comp-cstr-union-make + (mapcar #'comp-type-spec-to-cstr rest))) + (`(and . ,rest) + (apply #'comp-cstr-intersection-make + (mapcar #'comp-type-spec-to-cstr rest))) + (`(not ,cstr) + (comp-cstr-negation-make (comp-type-spec-to-cstr cstr))) + (`(integer ,(and (pred integerp) l) ,(and (pred integerp) h)) + (comp-irange-to-cstr `(,l . ,h))) + (`(integer * ,(and (pred integerp) h)) + (comp-irange-to-cstr `(- . ,h))) + (`(integer ,(and (pred integerp) l) *) + (comp-irange-to-cstr `(,l . +))) + (`(float ,(pred comp-star-or-num-p) ,(pred comp-star-or-num-p)) + ;; No float range support :/ + (comp-type-to-cstr 'float)) + (`(member . ,rest) + (apply #'comp-cstr-union-make (mapcar #'comp-value-to-cstr rest))) + (`(function ,args ,ret) + (make-comp-cstr-f + :args (mapcar (lambda (x) + (comp-type-spec-to-cstr x t)) + args) + :ret (comp-type-spec-to-cstr ret))) + (_ (error "Invalid type specifier")))) (defun comp-cstr-to-type-spec (cstr) "Given CSTR return its type specifier." @@ -562,7 +563,9 @@ FN non-nil indicates we are parsing a function lambda list." nil))) (final (pcase res - (`(,(or 'integer 'member) . ,rest) + ((or `(member . ,rest) + `(integer ,(pred comp-star-or-num-p) + ,(pred comp-star-or-num-p))) (if rest res (car res))) commit 726e40fb7c0eb50e6afe831997da445c32872eed Author: Andrea Corallo Date: Wed Dec 2 23:49:00 2020 +0100 Fix union of homogeneously negated input constraints * lisp/emacs-lisp/comp-cstr.el (comp-cstr-union-1): Fix logic. * test/lisp/emacs-lisp/comp-cstr-tests.el (comp-cstr-typespec-tests-alist): Add a couple of tests. diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el index 96aa67ec9d..3aad3dc2c2 100644 --- a/lisp/emacs-lisp/comp-cstr.el +++ b/lisp/emacs-lisp/comp-cstr.el @@ -325,6 +325,8 @@ DST is returned." finally (when (or (zerop n-pos) (zerop n-neg)) (apply #'comp-cstr-union-homogeneous dst srcs) + (when (zerop n-pos) + (setf (neg dst) t)) (cl-return-from comp-cstr-union-1 dst))) ;; Some are negated and some are not diff --git a/test/lisp/emacs-lisp/comp-cstr-tests.el b/test/lisp/emacs-lisp/comp-cstr-tests.el index 5c119c6ba3..0b10b7f80a 100644 --- a/test/lisp/emacs-lisp/comp-cstr-tests.el +++ b/test/lisp/emacs-lisp/comp-cstr-tests.el @@ -85,7 +85,9 @@ ((or symbol (not sequence)) . t) ((or vector (not sequence)) . (not sequence)) ((or (integer 1 10) (not (integer * 5))) . (integer 1 *)) - ((or symbol (integer 1 10) (not (integer * 5))) . (integer 1 *))) + ((or symbol (integer 1 10) (not (integer * 5))) . (integer 1 *)) + ((or symbol (not (member foo))) . (not (member foo))) + ((or (not symbol) (not (member foo))) . (not symbol))) "Alist type specifier -> expected type specifier.") (defmacro comp-cstr-synthesize-tests () commit cbbdb4e1993ffa0f9e467d8c2a6f86403bb6d675 Author: Andrea Corallo Date: Wed Dec 2 23:48:00 2020 +0100 * Add `with-comp-cstr-accessors' macro. * lisp/emacs-lisp/comp-cstr.el (with-comp-cstr-accessors): New macro. (comp-cstr-union-1): Make use of `with-comp-cstr-accessors'. diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el index a180996707..96aa67ec9d 100644 --- a/lisp/emacs-lisp/comp-cstr.el +++ b/lisp/emacs-lisp/comp-cstr.el @@ -86,6 +86,20 @@ Integer values are handled in the `range' slot.") :documentation "Serve memoization for `comp-common-supertype'.")) +(defmacro with-comp-cstr-accessors (&rest body) + "Define some quick accessor to reduce code vergosity in BODY." + (declare (debug (form body)) + (indent defun)) + `(cl-macrolet ((typeset (&rest x) + `(comp-cstr-typeset ,@x)) + (valset (&rest x) + `(comp-cstr-valset ,@x)) + (range (&rest x) + `(comp-cstr-range ,@x)) + (neg (&rest x) + `(comp-cstr-neg ,@x))) + ,@body)) + ;;; Type handling. @@ -299,86 +313,87 @@ DST is returned." "Combine SRCS by union set operation setting the result in DST. Do range propagation when RANGE is non-nil. DST is returned." - ;; Check first if we are in the simple case of all input non-negate - ;; or negated so we don't have to cons. - (cl-loop - for cstr in srcs - unless (comp-cstr-neg cstr) - count t into n-pos - else - count t into n-neg - finally - (when (or (zerop n-pos) (zerop n-neg)) - (apply #'comp-cstr-union-homogeneous dst srcs) - (cl-return-from comp-cstr-union-1 dst))) + (with-comp-cstr-accessors + ;; Check first if we are in the simple case of all input non-negate + ;; or negated so we don't have to cons. + (cl-loop + for cstr in srcs + unless (neg cstr) + count t into n-pos + else + count t into n-neg + finally + (when (or (zerop n-pos) (zerop n-neg)) + (apply #'comp-cstr-union-homogeneous dst srcs) + (cl-return-from comp-cstr-union-1 dst))) - ;; Some are negated and some are not - (cl-loop - for cstr in srcs - if (comp-cstr-neg cstr) - collect cstr into negatives - else - collect cstr into positives - finally - (let* ((pos (apply #'comp-cstr-union-homogeneous (make-comp-cstr) positives)) - (neg (apply #'comp-cstr-union-homogeneous (make-comp-cstr) negatives))) - - ;; Type propagation. - (when (and (comp-cstr-typeset pos) - ;; When some pos type is not a subtype of any neg ones. - (cl-every (lambda (x) - (cl-some (lambda (y) - (not (comp-subtype-p x y))) - (comp-cstr-typeset neg))) - (comp-cstr-typeset pos))) - ;; This is a conservative choice, ATM we can't represent such a - ;; disjoint set of types unless we decide to add a new slot - ;; into `comp-cstr' list them all. This probably wouldn't - ;; work for the future when we'll support also non-builtin - ;; types. - (setf (comp-cstr-typeset dst) '(t) - (comp-cstr-valset dst) () - (comp-cstr-range dst) () - (comp-cstr-neg dst) nil) - (cl-return-from comp-cstr-union-1 dst)) - - ;; Value propagation. - (setf (comp-cstr-valset neg) - (cl-nset-difference (comp-cstr-valset neg) (comp-cstr-valset pos))) - - ;; Range propagation - (when (and range - (or (comp-cstr-range pos) - (comp-cstr-range neg)) - (cl-notany (lambda (x) - (comp-subtype-p 'integer x)) - (comp-cstr-typeset pos))) - (if (or (comp-cstr-valset neg) - (comp-cstr-typeset neg)) - (setf (comp-cstr-range neg) - (comp-range-union (comp-range-negation (comp-cstr-range pos)) - (comp-cstr-range neg))) - ;; When possibile do not return a negated cstr. - (setf (comp-cstr-typeset dst) () - (comp-cstr-valset dst) () - (comp-cstr-range dst) (comp-range-union - (comp-range-negation (comp-cstr-range neg)) - (comp-cstr-range pos)) - (comp-cstr-neg dst) nil) - (cl-return-from comp-cstr-union-1 dst))) - - (if (and (null (comp-cstr-typeset neg)) - (null (comp-cstr-valset neg)) - (null (comp-cstr-range neg))) - (setf (comp-cstr-typeset dst) '(t) - (comp-cstr-valset dst) () - (comp-cstr-range dst) () - (comp-cstr-neg dst) nil) - (setf (comp-cstr-typeset dst) (comp-cstr-typeset neg) - (comp-cstr-valset dst) (comp-cstr-valset neg) - (comp-cstr-range dst) (comp-cstr-range neg) - (comp-cstr-neg dst) t)))) - dst) + ;; Some are negated and some are not + (cl-loop + for cstr in srcs + if (neg cstr) + collect cstr into negatives + else + collect cstr into positives + finally + (let* ((pos (apply #'comp-cstr-union-homogeneous (make-comp-cstr) positives)) + (neg (apply #'comp-cstr-union-homogeneous (make-comp-cstr) negatives))) + + ;; Type propagation. + (when (and (typeset pos) + ;; When some pos type is not a subtype of any neg ones. + (cl-every (lambda (x) + (cl-some (lambda (y) + (not (comp-subtype-p x y))) + (typeset neg))) + (typeset pos))) + ;; This is a conservative choice, ATM we can't represent such a + ;; disjoint set of types unless we decide to add a new slot + ;; into `comp-cstr' list them all. This probably wouldn't + ;; work for the future when we'll support also non-builtin + ;; types. + (setf (typeset dst) '(t) + (valset dst) () + (range dst) () + (neg dst) nil) + (cl-return-from comp-cstr-union-1 dst)) + + ;; Value propagation. + (setf (valset neg) + (cl-nset-difference (valset neg) (valset pos))) + + ;; Range propagation + (when (and range + (or (range pos) + (range neg)) + (cl-notany (lambda (x) + (comp-subtype-p 'integer x)) + (typeset pos))) + (if (or (valset neg) + (typeset neg)) + (setf (range neg) + (comp-range-union (comp-range-negation (range pos)) + (range neg))) + ;; When possibile do not return a negated cstr. + (setf (typeset dst) () + (valset dst) () + (range dst) (comp-range-union + (comp-range-negation (range neg)) + (range pos)) + (neg dst) nil) + (cl-return-from comp-cstr-union-1 dst))) + + (if (and (null (typeset neg)) + (null (valset neg)) + (null (range neg))) + (setf (typeset dst) '(t) + (valset dst) () + (range dst) () + (neg dst) nil) + (setf (typeset dst) (typeset neg) + (valset dst) (valset neg) + (range dst) (range neg) + (neg dst) t)))) + dst)) ;;; Entry points. commit 7c1d90a41df8792f7311f0ec5a33c613f08ac4ae Author: Andrea Corallo Date: Wed Dec 2 22:47:00 2020 +0100 Initial support for union of negated constraints * lisp/emacs-lisp/comp-cstr.el (comp-range-negation): New function. (comp-cstr-union-homogeneous-no-range): Rename from `comp-cstr-union-no-range'. (comp-cstr-union-homogeneous): Rename from `comp-cstr-union'. (comp-cstr-union-1): New function. (comp-cstr-union-no-range, comp-cstr-union): Rewrite in function of `comp-cstr-union-1'. * test/lisp/emacs-lisp/comp-cstr-tests.el (comp-cstr-typespec-tests-alist): Add a bunch of tests. diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el index 6397bccdae..a180996707 100644 --- a/lisp/emacs-lisp/comp-cstr.el +++ b/lisp/emacs-lisp/comp-cstr.el @@ -239,23 +239,26 @@ Integer values are handled in the `range' slot.") (defun comp-range-negation (range) "Negate range RANGE." - (cl-loop - with res = () - with last-h = '- - for (l . h) in range - unless (eq l '-) + (if (null range) + '((- . +)) + (cl-loop + with res = () + with last-h = '- + for (l . h) in range + unless (eq l '-) do (push `(,(comp-range-1+ last-h) . ,(1- l)) res) - do (setf last-h h) - finally - (unless (eq '+ last-h) - (push `(,(1+ last-h) . +) res)) - (cl-return (reverse res)))) + do (setf last-h h) + finally + (unless (eq '+ last-h) + (push `(,(1+ last-h) . +) res)) + (cl-return (reverse res))))) -;;; Entry points. +;;; Union specific code. -(defun comp-cstr-union-no-range (dst &rest srcs) - "As `comp-cstr-union' but escluding the irange component." +(defun comp-cstr-union-homogeneous-no-range (dst &rest srcs) + "As `comp-cstr-union' but escluding the irange component. +All SRCS constraints must be homogeneously negated or non-negated." ;; Type propagation. (setf (comp-cstr-typeset dst) @@ -277,10 +280,11 @@ Integer values are handled in the `range' slot.") dst) -(defun comp-cstr-union (dst &rest srcs) +(defun comp-cstr-union-homogeneous (dst &rest srcs) "Combine SRCS by union set operation setting the result in DST. +All SRCS constraints must be homogeneously negated or non-negated. DST is returned." - (apply #'comp-cstr-union-no-range dst srcs) + (apply #'comp-cstr-union-homogeneous-no-range dst srcs) ;; Range propagation. (setf (comp-cstr-range dst) (when (cl-notany (lambda (x) @@ -291,6 +295,105 @@ DST is returned." (mapcar #'comp-cstr-range srcs)))) dst) +(cl-defun comp-cstr-union-1 (range dst &rest srcs) + "Combine SRCS by union set operation setting the result in DST. +Do range propagation when RANGE is non-nil. +DST is returned." + ;; Check first if we are in the simple case of all input non-negate + ;; or negated so we don't have to cons. + (cl-loop + for cstr in srcs + unless (comp-cstr-neg cstr) + count t into n-pos + else + count t into n-neg + finally + (when (or (zerop n-pos) (zerop n-neg)) + (apply #'comp-cstr-union-homogeneous dst srcs) + (cl-return-from comp-cstr-union-1 dst))) + + ;; Some are negated and some are not + (cl-loop + for cstr in srcs + if (comp-cstr-neg cstr) + collect cstr into negatives + else + collect cstr into positives + finally + (let* ((pos (apply #'comp-cstr-union-homogeneous (make-comp-cstr) positives)) + (neg (apply #'comp-cstr-union-homogeneous (make-comp-cstr) negatives))) + + ;; Type propagation. + (when (and (comp-cstr-typeset pos) + ;; When some pos type is not a subtype of any neg ones. + (cl-every (lambda (x) + (cl-some (lambda (y) + (not (comp-subtype-p x y))) + (comp-cstr-typeset neg))) + (comp-cstr-typeset pos))) + ;; This is a conservative choice, ATM we can't represent such a + ;; disjoint set of types unless we decide to add a new slot + ;; into `comp-cstr' list them all. This probably wouldn't + ;; work for the future when we'll support also non-builtin + ;; types. + (setf (comp-cstr-typeset dst) '(t) + (comp-cstr-valset dst) () + (comp-cstr-range dst) () + (comp-cstr-neg dst) nil) + (cl-return-from comp-cstr-union-1 dst)) + + ;; Value propagation. + (setf (comp-cstr-valset neg) + (cl-nset-difference (comp-cstr-valset neg) (comp-cstr-valset pos))) + + ;; Range propagation + (when (and range + (or (comp-cstr-range pos) + (comp-cstr-range neg)) + (cl-notany (lambda (x) + (comp-subtype-p 'integer x)) + (comp-cstr-typeset pos))) + (if (or (comp-cstr-valset neg) + (comp-cstr-typeset neg)) + (setf (comp-cstr-range neg) + (comp-range-union (comp-range-negation (comp-cstr-range pos)) + (comp-cstr-range neg))) + ;; When possibile do not return a negated cstr. + (setf (comp-cstr-typeset dst) () + (comp-cstr-valset dst) () + (comp-cstr-range dst) (comp-range-union + (comp-range-negation (comp-cstr-range neg)) + (comp-cstr-range pos)) + (comp-cstr-neg dst) nil) + (cl-return-from comp-cstr-union-1 dst))) + + (if (and (null (comp-cstr-typeset neg)) + (null (comp-cstr-valset neg)) + (null (comp-cstr-range neg))) + (setf (comp-cstr-typeset dst) '(t) + (comp-cstr-valset dst) () + (comp-cstr-range dst) () + (comp-cstr-neg dst) nil) + (setf (comp-cstr-typeset dst) (comp-cstr-typeset neg) + (comp-cstr-valset dst) (comp-cstr-valset neg) + (comp-cstr-range dst) (comp-cstr-range neg) + (comp-cstr-neg dst) t)))) + dst) + + +;;; Entry points. + +(defun comp-cstr-union-no-range (dst &rest srcs) + "Combine SRCS by union set operation setting the result in DST. +Do not propagate the range component. +DST is returned." + (apply #'comp-cstr-union-1 nil dst srcs)) + +(defun comp-cstr-union (dst &rest srcs) + "Combine SRCS by union set operation setting the result in DST. +DST is returned." + (apply #'comp-cstr-union-1 t dst srcs)) + (defun comp-cstr-union-make (&rest srcs) "Combine SRCS by union set operation and return a new constraint." (apply #'comp-cstr-union (make-comp-cstr) srcs)) diff --git a/test/lisp/emacs-lisp/comp-cstr-tests.el b/test/lisp/emacs-lisp/comp-cstr-tests.el index 541533601b..5c119c6ba3 100644 --- a/test/lisp/emacs-lisp/comp-cstr-tests.el +++ b/test/lisp/emacs-lisp/comp-cstr-tests.el @@ -78,7 +78,14 @@ ((and (integer -1 3) (integer 3 5)) . (integer 3 3)) ((and (integer -1 4) (integer 3 5)) . (integer 3 4)) ((and (integer -1 5) nil) . nil) - ((not symbol) . (not symbol))) + ((not symbol) . (not symbol)) + ((or (member foo) (not (member foo bar))) . (not (member bar))) + ((or (member foo bar) (not (member foo))) . t) + ;; Intentionally conservative, see `comp-cstr-union'. + ((or symbol (not sequence)) . t) + ((or vector (not sequence)) . (not sequence)) + ((or (integer 1 10) (not (integer * 5))) . (integer 1 *)) + ((or symbol (integer 1 10) (not (integer * 5))) . (integer 1 *))) "Alist type specifier -> expected type specifier.") (defmacro comp-cstr-synthesize-tests () commit 1fb249f6db1ae87ee3ddd221ab9c8d152951efe7 Author: Andrea Corallo Date: Wed Dec 2 22:45:00 2020 +0100 * lisp/emacs-lisp/comp-cstr.el (comp-cstr-union-no-range): Cosmetic. diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el index dcf835bb7b..6397bccdae 100644 --- a/lisp/emacs-lisp/comp-cstr.el +++ b/lisp/emacs-lisp/comp-cstr.el @@ -256,26 +256,26 @@ Integer values are handled in the `range' slot.") (defun comp-cstr-union-no-range (dst &rest srcs) "As `comp-cstr-union' but escluding the irange component." - (let ((values (mapcar #'comp-cstr-valset srcs))) - - ;; Type propagation. - (setf (comp-cstr-typeset dst) - (apply #'comp-union-typesets (mapcar #'comp-cstr-typeset srcs))) - - ;; Value propagation. - (setf (comp-cstr-valset dst) - (cl-loop - ;; TODO sort. - for v in (cl-remove-duplicates (apply #'append values) - :test #'equal) - ;; We propagate only values those types are not already - ;; into typeset. - when (cl-notany (lambda (x) - (comp-subtype-p (type-of v) x)) - (comp-cstr-typeset dst)) - collect v)) - - dst)) + + ;; Type propagation. + (setf (comp-cstr-typeset dst) + (apply #'comp-union-typesets (mapcar #'comp-cstr-typeset srcs))) + + ;; Value propagation. + (setf (comp-cstr-valset dst) + (cl-loop + with values = (mapcar #'comp-cstr-valset srcs) + ;; TODO sort. + for v in (cl-remove-duplicates (apply #'append values) + :test #'equal) + ;; We propagate only values those types are not already + ;; into typeset. + when (cl-notany (lambda (x) + (comp-subtype-p (type-of v) x)) + (comp-cstr-typeset dst)) + collect v)) + + dst) (defun comp-cstr-union (dst &rest srcs) "Combine SRCS by union set operation setting the result in DST. commit 9b85ae6aa5d73649c0a48d5168d4de52ee83ac28 Author: Andrea Corallo Date: Wed Dec 2 21:44:00 2020 +0100 Initial constraint negation support * lisp/emacs-lisp/comp-cstr.el (comp-cstr): Add `neg' slot. (comp-range-negation, comp-cstr-negation) (comp-cstr-negation-make): New functions. (comp-type-spec-to-cstr): Enable `not` in type specifiers. (comp-cstr-to-type-spec): Update logic to handle negation. * test/lisp/emacs-lisp/comp-cstr-tests.el (comp-cstr-typespec-tests-alist): Add a test. diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el index 40fa48ee8e..dcf835bb7b 100644 --- a/lisp/emacs-lisp/comp-cstr.el +++ b/lisp/emacs-lisp/comp-cstr.el @@ -66,7 +66,9 @@ Each element cannot be a subtype of any other element of this slot.") :documentation "List of possible values the mvar can assume. Integer values are handled in the `range' slot.") (range () :type list - :documentation "Integer interval.")) + :documentation "Integer interval.") + (neg nil :type boolean + :documentation "Non-nil if the constraint is negated")) (cl-defstruct comp-cstr-f "Internal constraint representation for a function." @@ -235,6 +237,20 @@ Integer values are handled in the `range' slot.") (cl-decf nest) finally (cl-return (reverse res)))) +(defun comp-range-negation (range) + "Negate range RANGE." + (cl-loop + with res = () + with last-h = '- + for (l . h) in range + unless (eq l '-) + do (push `(,(comp-range-1+ last-h) . ,(1- l)) res) + do (setf last-h h) + finally + (unless (eq '+ last-h) + (push `(,(1+ last-h) . +) res)) + (cl-return (reverse res)))) + ;;; Entry points. @@ -332,6 +348,19 @@ DST is returned." "Combine SRCS by intersection set operation and return a new constraint." (apply #'comp-cstr-intersection (make-comp-cstr) srcs)) +(defun comp-cstr-negation (dst src) + "Negate SRC setting the result in DST. +DST is returned." + (setf (comp-cstr-typeset dst) (comp-cstr-typeset src) + (comp-cstr-valset dst) (comp-cstr-valset src) + (comp-cstr-range dst) (comp-cstr-range src) + (comp-cstr-neg dst) (not (comp-cstr-neg src))) + dst) + +(defun comp-cstr-negation-make (src) + "Negate SRC and return a new constraint." + (comp-cstr-negation (make-comp-cstr) src)) + (defun comp-type-spec-to-cstr (type-spec &optional fn) "Convert a type specifier TYPE-SPEC into a `comp-cstr'. FN non-nil indicates we are parsing a function lambda list." @@ -356,10 +385,7 @@ FN non-nil indicates we are parsing a function lambda list." (apply #'comp-cstr-intersection-make (mapcar #'comp-type-spec-to-cstr rest))) (`(not ,cstr) - (cl-assert nil) - ;; TODO - ;; (comp-cstr-negate-make (comp-type-spec-to-cstr cstr)) - ) + (comp-cstr-negation-make (comp-type-spec-to-cstr cstr))) (`(integer ,(and (pred integerp) l) ,(and (pred integerp) h)) (comp-irange-to-cstr `(,l . ,h))) (`(integer * ,(and (pred integerp) h)) @@ -383,7 +409,8 @@ FN non-nil indicates we are parsing a function lambda list." "Given CSTR return its type specifier." (let ((valset (comp-cstr-valset cstr)) (typeset (comp-cstr-typeset cstr)) - (range (comp-cstr-range cstr))) + (range (comp-cstr-range cstr)) + (negated (comp-cstr-neg cstr))) (when valset (when (memq nil valset) @@ -412,17 +439,21 @@ FN non-nil indicates we are parsing a function lambda list." (valset `(member ,@valset)) (t ;; Empty type specifier - nil)))) - (pcase res - (`(,(or 'integer 'member) . ,rest) - (if rest - res - (car res))) - ((pred atom) res) - (`(,_first . ,rest) - (if rest - `(or ,@res) - (car res))))))) + nil))) + (final + (pcase res + (`(,(or 'integer 'member) . ,rest) + (if rest + res + (car res))) + ((pred atom) res) + (`(,_first . ,rest) + (if rest + `(or ,@res) + (car res)))))) + (if negated + `(not ,final) + final)))) (provide 'comp-cstr) diff --git a/test/lisp/emacs-lisp/comp-cstr-tests.el b/test/lisp/emacs-lisp/comp-cstr-tests.el index c98ff80cd7..541533601b 100644 --- a/test/lisp/emacs-lisp/comp-cstr-tests.el +++ b/test/lisp/emacs-lisp/comp-cstr-tests.el @@ -77,7 +77,8 @@ ((and (integer -1 2) (integer 3 5)) . nil) ((and (integer -1 3) (integer 3 5)) . (integer 3 3)) ((and (integer -1 4) (integer 3 5)) . (integer 3 4)) - ((and (integer -1 5) nil) . nil)) + ((and (integer -1 5) nil) . nil) + ((not symbol) . (not symbol))) "Alist type specifier -> expected type specifier.") (defmacro comp-cstr-synthesize-tests () commit eb8d15547bfc0821232af12c1ce193e40cdf16c0 Author: Andrea Corallo Date: Fri Dec 4 22:45:59 2020 +0100 * Do not compile `comp-cstr.el` in vanilla builds * lisp/Makefile.in (compile-targets): Filter out 'comp-cstr.elc' in vanilla builds. diff --git a/lisp/Makefile.in b/lisp/Makefile.in index 5fec921b07..c6a1799e36 100644 --- a/lisp/Makefile.in +++ b/lisp/Makefile.in @@ -342,7 +342,7 @@ compile-first: $(COMPILE_FIRST) # Do not build comp.el unless necessary not to exceed max-specpdl-size and # max-lisp-eval-depth in normal builds. ifneq ($(HAVE_NATIVE_COMP),yes) -compile-targets: $(filter-out ./emacs-lisp/comp.elc,$(TARGETS)) +compile-targets: $(filter-out ./emacs-lisp/comp-cstr.elc,$(filter-out ./emacs-lisp/comp.elc,$(TARGETS))) else compile-targets: $(TARGETS) endif commit 39bdb3f6f54cdba80f1efbecab4bbb08428e7cc8 Author: Andrea Corallo Date: Fri Dec 4 22:31:36 2020 +0100 Vanilla build warning clean-up * lisp/emacs-lisp/disass.el (native-comp-unit-file) (subr-native-comp-unit): Declare function. * lisp/progmodes/elisp-mode.el (native-compile): Likewise. * lisp/emacs-lisp/package.el (comp-el-to-eln-filename): Likewise. * lisp/startup.el (normal-top-level): Silence warning. * src/data.c (syms_of_data): 'Ssubr_native_lambda_list' is always defined. * src/pdumper.c (dump_cold_native_subr): Move under ifdefs. (dump_drain_cold_data): Add ifdefs. diff --git a/lisp/emacs-lisp/disass.el b/lisp/emacs-lisp/disass.el index 7e7db7b441..7fb370f5df 100644 --- a/lisp/emacs-lisp/disass.el +++ b/lisp/emacs-lisp/disass.el @@ -75,7 +75,8 @@ redefine OBJECT if it is a symbol." (disassemble-internal object indent nil))) nil) - +(declare-function native-comp-unit-file "data.c") +(declare-function subr-native-comp-unit "data.c") (cl-defun disassemble-internal (obj indent interactive-p) (let ((macro 'nil) (name (when (symbolp obj) diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index 0ee2e58d52..e980f8841e 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -2221,6 +2221,7 @@ If some packages are not installed propose to install them." (equal (cadr (assq (package-desc-name pkg) package-alist)) pkg)) +(declare-function comp-el-to-eln-filename "comp.c") (defun package--delete-directory (dir) "Delete DIR recursively. Clean-up the corresponding .eln files if Emacs is native diff --git a/lisp/progmodes/elisp-mode.el b/lisp/progmodes/elisp-mode.el index dac3aaf2a5..13bba7f77a 100644 --- a/lisp/progmodes/elisp-mode.el +++ b/lisp/progmodes/elisp-mode.el @@ -203,6 +203,7 @@ All commands in `lisp-mode-shared-map' are inherited by this map.") (byte-recompile-file buffer-file-name nil 0) (load buffer-file-name)) +(declare-function native-compile "comp") (defun emacs-lisp-native-compile-and-load () "Native-compile synchronously the current file (if it has changed). Load the compiled code when finished. diff --git a/lisp/startup.el b/lisp/startup.el index 2beeaa195d..f9de7fa94f 100644 --- a/lisp/startup.el +++ b/lisp/startup.el @@ -535,6 +535,7 @@ It is the default value of the variable `top-level'." (startup--xdg-or-homedot startup--xdg-config-home-emacs nil)) (when (featurep 'nativecomp) + (defvar comp-eln-load-path) (let ((path-env (getenv "EMACSNATIVELOADPATH"))) (when path-env (dolist (path (split-string path-env ":")) diff --git a/src/data.c b/src/data.c index 1435cb0377..fea39867c9 100644 --- a/src/data.c +++ b/src/data.c @@ -4055,8 +4055,8 @@ syms_of_data (void) defsubr (&Ssubr_arity); defsubr (&Ssubr_name); defsubr (&Ssubr_native_elisp_p); -#ifdef HAVE_NATIVE_COMP defsubr (&Ssubr_native_lambda_list); +#ifdef HAVE_NATIVE_COMP defsubr (&Ssubr_native_comp_unit); defsubr (&Snative_comp_unit_file); defsubr (&Snative_comp_unit_set_file); diff --git a/src/pdumper.c b/src/pdumper.c index 1a7aee6343..b3abbd66f0 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -3405,6 +3405,7 @@ dump_cold_bignum (struct dump_context *ctx, Lisp_Object object) } } +#ifdef HAVE_NATIVE_COMP static void dump_cold_native_subr (struct dump_context *ctx, Lisp_Object subr) { @@ -3425,6 +3426,7 @@ dump_cold_native_subr (struct dump_context *ctx, Lisp_Object subr) const char *c_name = XSUBR (subr)->native_c_name[0]; dump_write (ctx, c_name, 1 + strlen (c_name)); } +#endif static void dump_drain_cold_data (struct dump_context *ctx) @@ -3469,9 +3471,11 @@ dump_drain_cold_data (struct dump_context *ctx) case COLD_OP_BIGNUM: dump_cold_bignum (ctx, data); break; +#ifdef HAVE_NATIVE_COMP case COLD_OP_NATIVE_SUBR: dump_cold_native_subr (ctx, data); break; +#endif default: emacs_abort (); } commit dcfd367d282ab37f00373a424fd193022a8f4bf6 Author: Andrea Corallo Date: Fri Dec 4 22:05:20 2020 +0100 * Fix `load-history' causing a number of spurious compiler warnings * src/comp.c (Fcomp__register_subr): Fix missing entry into `load-history' indicating that the loaded function was already an autoload. diff --git a/src/comp.c b/src/comp.c index 590e330741..1842aeb839 100644 --- a/src/comp.c +++ b/src/comp.c @@ -5051,6 +5051,9 @@ This gets called by top_level_run during the load phase. */) make_subr (SYMBOL_NAME (name), minarg, maxarg, c_name, doc_idx, intspec, comp_u); + if (AUTOLOADP (XSYMBOL (name)->u.s.function)) + /* Remember that the function was already an autoload. */ + LOADHIST_ATTACH (Fcons (Qt, name)); LOADHIST_ATTACH (Fcons (Qdefun, name)); { /* Handle automatic advice activation (bug#42038). commit 981240078cddbd26b35a65e5311350196542b42b Author: Andrea Corallo Date: Thu Dec 3 17:13:39 2020 +0100 * Reduce (half) the number of loads emitted for calling into C code As after each function call GCC clobbers the pointer to the function relocation table. This commit modify the code generation to create a local copy of it for each function. This reduces the average number of loads for each function call into C from two to one. * src/comp.c (comp_t): Add 'func_relocs_ptr_type' and 'func_relocs_local' fields. (emit_call): Use the local func_relocs pointer when possible. (emit_ctxt_code): Fill 'comp.func_relocs_ptr_type'. (compile_function): Declare 'func_relocs_ptr_local'. (compile_function): Assign 'func_relocs_ptr_local' from the global value in each function prologue. diff --git a/src/comp.c b/src/comp.c index 12ff985d23..590e330741 100644 --- a/src/comp.c +++ b/src/comp.c @@ -580,8 +580,11 @@ typedef struct { gcc_jit_rvalue *data_relocs_impure; /* Same as before but content does not survive load phase. */ gcc_jit_rvalue *data_relocs_ephemeral; - /* Synthesized struct holding func relocs. */ + /* Global structure holding function relocations. */ gcc_jit_lvalue *func_relocs; + gcc_jit_type *func_relocs_ptr_type; + /* Pointer to this structure local to each function. */ + gcc_jit_lvalue *func_relocs_local; gcc_jit_function *memcpy; Lisp_Object d_default_idx; Lisp_Object d_impure_idx; @@ -1013,9 +1016,17 @@ emit_call (Lisp_Object func, gcc_jit_type *ret_type, ptrdiff_t nargs, } else { + /* Inline functions so far don't have a local variable for + function reloc table so we fall back to the global one. Even + if this is not aesthetic calling into C from open-code is + always a fallback and therefore not be performance critical. + To fix this could think do the inline our-self without + relying on GCC. */ gcc_jit_lvalue *f_ptr = gcc_jit_rvalue_dereference_field ( - gcc_jit_lvalue_as_rvalue (comp.func_relocs), + gcc_jit_lvalue_as_rvalue (comp.func_relocs_local + ? comp.func_relocs_local + : comp.func_relocs), NULL, (gcc_jit_field *) xmint_pointer (gcc_func)); @@ -2862,15 +2873,16 @@ emit_ctxt_code (void) NULL, "freloc_link_table", n_frelocs, fields); + comp.func_relocs_ptr_type = + gcc_jit_type_get_pointer ( + gcc_jit_struct_as_type (f_reloc_struct)); + comp.func_relocs = - gcc_jit_context_new_global ( - comp.ctxt, - NULL, - GCC_JIT_GLOBAL_EXPORTED, - gcc_jit_type_get_pointer ( - gcc_jit_type_get_const ( - gcc_jit_struct_as_type (f_reloc_struct))), - FUNC_LINK_TABLE_SYM); + gcc_jit_context_new_global (comp.ctxt, + NULL, + GCC_JIT_GLOBAL_EXPORTED, + comp.func_relocs_ptr_type, + FUNC_LINK_TABLE_SYM); xfree (fields); } @@ -3931,6 +3943,12 @@ compile_function (Lisp_Object func) comp.func_has_non_local = !NILP (CALL1I (comp-func-has-non-local, func)); comp.func_speed = XFIXNUM (CALL1I (comp-func-speed, func)); + comp.func_relocs_local = + gcc_jit_function_new_local (comp.func, + NULL, + comp.func_relocs_ptr_type, + "freloc"); + comp.frame = SAFE_ALLOCA (frame_size * sizeof (*comp.frame)); if (comp.func_has_non_local || !comp.func_speed) { @@ -3985,6 +4003,12 @@ compile_function (Lisp_Object func) declare_block (HASH_KEY (ht, i)); } + gcc_jit_block_add_assignment (retrive_block (Qentry), + NULL, + comp.func_relocs_local, + gcc_jit_lvalue_as_rvalue (comp.func_relocs)); + + for (ptrdiff_t i = 0; i < ht->count; i++) { Lisp_Object block_name = HASH_KEY (ht, i); @@ -4397,6 +4421,8 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, CHECK_STRING (filename); Lisp_Object base_name = Fsubstring (filename, Qnil, make_fixnum (-4)); + comp.func_relocs_local = NULL; + comp.speed = XFIXNUM (CALL1I (comp-ctxt-speed, Vcomp_ctxt)); comp.debug = XFIXNUM (CALL1I (comp-ctxt-debug, Vcomp_ctxt)); commit 21104e6808a4496afb8163d92c6fb4d59e3010b7 Author: Andrea Corallo Date: Mon Nov 30 23:46:48 2020 +0100 Fix `comp-mvar-symbol-p' and `comp-mvar-cons-p' (bug#44968) * lisp/emacs-lisp/comp.el (comp-mvar-symbol-p): As all slots into a `comp-cstr' are in or fix this logic. (comp-mvar-cons-p): Likewise. * test/src/comp-tests.el (bug-44968): New testcase. * test/src/comp-test-funcs.el (comp-test-44968-f): New test function. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 498aae183a..13f9beb5f9 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -550,12 +550,18 @@ CFG is mutated by a pass.") (defun comp-mvar-symbol-p (mvar) "Return t if MVAR is certainly a symbol." - (or (equal (comp-mvar-typeset mvar) '(symbol)) - (cl-every #'symbolp (comp-mvar-valset mvar)))) + (and (null (comp-mvar-range mvar)) + (or (and (null (comp-mvar-valset mvar)) + (equal (comp-mvar-typeset mvar) '(symbol))) + (and (or (null (comp-mvar-typeset mvar)) + (equal (comp-mvar-typeset mvar) '(symbol))) + (cl-every #'symbolp (comp-mvar-valset mvar)))))) (defsubst comp-mvar-cons-p (mvar) "Return t if MVAR is certainly a cons." - (equal (comp-mvar-typeset mvar) '(cons))) + (and (null (comp-mvar-valset mvar)) + (null (comp-mvar-range mvar)) + (equal (comp-mvar-typeset mvar) '(cons)))) (defun comp-mvar-type-hint-match-p (mvar type-hint) "Match MVAR against TYPE-HINT. diff --git a/test/src/comp-test-funcs.el b/test/src/comp-test-funcs.el index 207b6455f7..5fa427be19 100644 --- a/test/src/comp-test-funcs.el +++ b/test/src/comp-test-funcs.el @@ -380,6 +380,16 @@ it nil))) +(defun comp-test-44968-f (start end) + (let ((dirlist) + (dir (expand-file-name start)) + (end (expand-file-name end))) + (while (not (or (equal dir (car dirlist)) + (file-equal-p dir end))) + (push dir dirlist) + (setq dir (directory-file-name (file-name-directory dir)))) + (nreverse dirlist))) + ;;;;;;;;;;;;;;;;;;;; ;; Tromey's tests ;; diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index dd97ccd5bd..c2af52e4ca 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -391,6 +391,10 @@ https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-03/msg00914.html." (should (string= (comp-test-42360-f "Nel mezzo del " 18 0 32 "yyy" nil) "Nel mezzo del yyy"))) +(comp-deftest bug-44968 () + "" + (comp-test-44968-f "/tmp/test/foo" "/tmp")) + (defvar comp-test-primitive-advice) (comp-deftest primitive-advice () "Test effectiveness of primitive advicing." commit 6523b8401519a29ca0aefaf44c3dfa36f681f64e Merge: 2e0256e0a0 38ed05f49f Author: Andrea Corallo Date: Sun Nov 29 15:11:38 2020 +0100 Merge remote-tracking branch 'savannah/master' into HEAD commit 2e0256e0a02edad129e0af1ea97b9e263c5d83fb Author: Andrea Corallo Date: Fri Nov 27 21:30:03 2020 +0100 Add intersection support into comp-cstr.el diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el index fcbb32fab2..40fa48ee8e 100644 --- a/lisp/emacs-lisp/comp-cstr.el +++ b/lisp/emacs-lisp/comp-cstr.el @@ -143,6 +143,19 @@ Integer values are handled in the `range' slot.") finally (cl-return (cl-remove-duplicates res))) (comp-cstr-ctxt-union-typesets-mem comp-ctxt)))) +(defun comp-intersect-typesets (&rest typesets) + "Intersect types present into TYPESETS." + (when-let ((ty (apply #'append typesets))) + (if (> (length ty) 1) + (cl-reduce + (lambda (x y) + (let ((st (comp-common-supertype-2 x y))) + (cond + ((eq st x) (list y)) + ((eq st y) (list x))))) + ty) + ty))) + ;;; Integer range handling @@ -252,7 +265,7 @@ Integer values are handled in the `range' slot.") "Combine SRCS by union set operation setting the result in DST. DST is returned." (apply #'comp-cstr-union-no-range dst srcs) - ;; Range propagation + ;; Range propagation. (setf (comp-cstr-range dst) (when (cl-notany (lambda (x) (comp-subtype-p 'integer x)) @@ -266,6 +279,59 @@ DST is returned." "Combine SRCS by union set operation and return a new constraint." (apply #'comp-cstr-union (make-comp-cstr) srcs)) +;; TODO memoize +(cl-defun comp-cstr-intersection (dst &rest srcs) + "Combine SRCS by intersection set operation setting the result in DST. +DST is returned." + + ;; Value propagation. + (setf (comp-cstr-valset dst) + ;; TODO sort. + (let ((values (cl-loop for src in srcs + for v = (comp-cstr-valset src) + when v + collect v))) + (when values + (cl-reduce (lambda (x y) + (cl-intersection x y :test #'equal)) + values)))) + + ;; Range propagation. + (when (cl-some #'identity (mapcar #'comp-cstr-range srcs)) + (if (comp-cstr-valset dst) + (progn + (setf (comp-cstr-valset dst) nil + (comp-cstr-range dst) nil + (comp-cstr-typeset dst) nil) + (cl-return-from comp-cstr-intersection dst)) + ;; TODO memoize? + (setf (comp-cstr-range dst) + (apply #'comp-range-intersection + (mapcar #'comp-cstr-range srcs))))) + + ;; Type propagation. + (setf (comp-cstr-typeset dst) + (if (or (comp-cstr-range dst) (comp-cstr-valset dst)) + (cl-loop + with type-val = (cl-remove-duplicates + (append (mapcar #'type-of + (comp-cstr-valset dst)) + (when (comp-cstr-range dst) + '(integer)))) + for type in (apply #'comp-intersect-typesets + (mapcar #'comp-cstr-typeset srcs)) + when (and type (not (member type type-val))) + do (setf (comp-cstr-valset dst) nil + (comp-cstr-range dst) nil) + (cl-return nil)) + (apply #'comp-intersect-typesets + (mapcar #'comp-cstr-typeset srcs)))) + dst) + +(defun comp-cstr-intersection-make (&rest srcs) + "Combine SRCS by intersection set operation and return a new constraint." + (apply #'comp-cstr-intersection (make-comp-cstr) srcs)) + (defun comp-type-spec-to-cstr (type-spec &optional fn) "Convert a type specifier TYPE-SPEC into a `comp-cstr'. FN non-nil indicates we are parsing a function lambda list." @@ -287,11 +353,8 @@ FN non-nil indicates we are parsing a function lambda list." (apply #'comp-cstr-union-make (mapcar #'comp-type-spec-to-cstr rest))) (`(and . ,rest) - (cl-assert nil) - ;; TODO - ;; (apply #'comp-cstr-intersect-make - ;; (mapcar #'comp-type-spec-to-cstr rest)) - ) + (apply #'comp-cstr-intersection-make + (mapcar #'comp-type-spec-to-cstr rest))) (`(not ,cstr) (cl-assert nil) ;; TODO @@ -351,7 +414,10 @@ FN non-nil indicates we are parsing a function lambda list." ;; Empty type specifier nil)))) (pcase res - (`(,(or 'integer 'member) . ,_rest) res) + (`(,(or 'integer 'member) . ,rest) + (if rest + res + (car res))) ((pred atom) res) (`(,_first . ,rest) (if rest diff --git a/test/lisp/emacs-lisp/comp-cstr-tests.el b/test/lisp/emacs-lisp/comp-cstr-tests.el index 38a5e29131..c98ff80cd7 100644 --- a/test/lisp/emacs-lisp/comp-cstr-tests.el +++ b/test/lisp/emacs-lisp/comp-cstr-tests.el @@ -48,15 +48,13 @@ ((or (or integer symbol) number) . (or symbol number)) ((or (or integer symbol) (or number list)) . (or list symbol number)) ((or (or integer number) nil) . number) - ;; ((and string array) . string) - ;; ((and cons atom) . (or cons atom)) - ;; ((and (member foo) (member bar)) . symbol) - ;; ((and (member foo) symbol) . (member foo)) ((member foo) . (member foo)) ((member foo bar) . (member foo bar)) ((or (member foo) (member bar)) . (member foo bar)) ((or (member foo) symbol) . symbol) ;; SBCL return (OR SYMBOL (MEMBER FOO)) ((or (member foo) number) . (or (member foo) number)) + ((or (integer 1 3) number) . number) + (integer . integer) ((integer 1 2) . (integer 1 2)) ((or (integer -1 0) (integer 3 4)) . (or (integer -1 0) (integer 3 4))) ((or (integer -1 2) (integer 3 4)) . (integer -1 4)) @@ -64,7 +62,22 @@ ((or (integer -1 4) (integer 3 4)) . (integer -1 4)) ((or (integer -1 5) (integer 3 4)) . (integer -1 5)) ((or (integer -1 *) (integer 3 4)) . (integer -1 *)) - ((or (integer -1 2) (integer * 4)) . (integer * 4))) + ((or (integer -1 2) (integer * 4)) . (integer * 4)) + ((and string array) . string) + ((and cons atom) . nil) + ((and (member foo) (member foo bar baz)) . (member foo)) + ((and (member foo) (member bar)) . nil) + ((and (member foo) symbol) . (member foo)) + ((and (member foo) string) . nil) + ((and (member foo) (integer 1 2)) . nil) + ((and (member 1 2) (member 3 2)) . (member 2)) + ((and number (integer 1 2)) . number) + ((and integer (integer 1 2)) . integer) + ((and (integer -1 0) (integer 3 5)) . nil) + ((and (integer -1 2) (integer 3 5)) . nil) + ((and (integer -1 3) (integer 3 5)) . (integer 3 3)) + ((and (integer -1 4) (integer 3 5)) . (integer 3 4)) + ((and (integer -1 5) nil) . nil)) "Alist type specifier -> expected type specifier.") (defmacro comp-cstr-synthesize-tests () diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 88c7b8c0d8..dd97ccd5bd 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -965,24 +965,4 @@ Return a list of results." (equal (comp-mvar-typeset mvar) comp-tests-cond-rw-expected-type)))))))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Range propagation tests. ;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;; FIXME to be removed when movable into comp-cstr-tests.el -(comp-deftest range-simple-intersection () - (should (equal (comp-range-intersection '((-1 . 0)) '((3 . 4))) - '())) - (should (equal (comp-range-intersection '((-1 . 2)) '((3 . 4))) - '())) - (should (equal (comp-range-intersection '((-1 . 3)) '((3 . 4))) - '((3 . 3)))) - (should (equal (comp-range-intersection '((-1 . 4)) '((3 . 4))) - '((3 . 4)))) - (should (equal (comp-range-intersection '((-1 . 5)) '((3 . 4))) - '((3 . 4)))) - (should (equal (comp-range-intersection '((-1 . 0)) '()) - '()))) - ;;; comp-tests.el ends here commit e2ff5d9605624baeae0fa500b00078b9f3e42e07 Author: Andrea Corallo Date: Fri Nov 27 18:31:53 2020 +0100 * Synthesize as const primitive function pointers and its container struct. * src/comp.c (declare_imported_func): Make const function pointer to primitive funcions. (emit_ctxt_code): Make struct 'comp.func_relocs' const. diff --git a/src/comp.c b/src/comp.c index 99560cc13a..12ff985d23 100644 --- a/src/comp.c +++ b/src/comp.c @@ -967,12 +967,13 @@ declare_imported_func (Lisp_Object subr_sym, gcc_jit_type *ret_type, subr_sym, make_string ("R", 1)); gcc_jit_type *f_ptr_type = - gcc_jit_context_new_function_ptr_type (comp.ctxt, - NULL, - ret_type, - nargs, - types, - 0); + gcc_jit_type_get_const ( + gcc_jit_context_new_function_ptr_type (comp.ctxt, + NULL, + ret_type, + nargs, + types, + 0)); gcc_jit_field *field = gcc_jit_context_new_field (comp.ctxt, NULL, @@ -2866,7 +2867,9 @@ emit_ctxt_code (void) comp.ctxt, NULL, GCC_JIT_GLOBAL_EXPORTED, - gcc_jit_type_get_pointer (gcc_jit_struct_as_type (f_reloc_struct)), + gcc_jit_type_get_pointer ( + gcc_jit_type_get_const ( + gcc_jit_struct_as_type (f_reloc_struct))), FUNC_LINK_TABLE_SYM); xfree (fields); commit 949b49cf771e8f38b23adb3fa4f9d7a9a5e290da Author: Andrea Corallo Date: Wed Nov 25 22:41:39 2020 +0100 Move some tests from comp-tests.el to comp-cstr-tests.el * test/lisp/emacs-lisp/comp-cstr-tests.el (comp-cstr-typespec-tests-alist): Add tests covering what was in: `range-simple-union', `union-types', `destructure-type-spec'. * test/src/comp-tests.el (range-simple-intersection, union-types) (destructure-type-spec): Remove tests. diff --git a/test/lisp/emacs-lisp/comp-cstr-tests.el b/test/lisp/emacs-lisp/comp-cstr-tests.el index 74419ff01e..38a5e29131 100644 --- a/test/lisp/emacs-lisp/comp-cstr-tests.el +++ b/test/lisp/emacs-lisp/comp-cstr-tests.el @@ -42,17 +42,29 @@ (defconst comp-cstr-typespec-tests-alist `((symbol . symbol) ((or string array) . array) - ;; ((and string array) . string) ((or symbol number) . (or symbol number)) ((or cons atom) . (or cons atom)) ;; SBCL return T + ((or integer number) . number) + ((or (or integer symbol) number) . (or symbol number)) + ((or (or integer symbol) (or number list)) . (or list symbol number)) + ((or (or integer number) nil) . number) + ;; ((and string array) . string) ;; ((and cons atom) . (or cons atom)) + ;; ((and (member foo) (member bar)) . symbol) + ;; ((and (member foo) symbol) . (member foo)) ((member foo) . (member foo)) ((member foo bar) . (member foo bar)) ((or (member foo) (member bar)) . (member foo bar)) - ;; ((and (member foo) (member bar)) . symbol) ((or (member foo) symbol) . symbol) ;; SBCL return (OR SYMBOL (MEMBER FOO)) - ;; ((and (member foo) symbol) . (member foo)) - ((or (member foo) number) . (or (member foo) number))) + ((or (member foo) number) . (or (member foo) number)) + ((integer 1 2) . (integer 1 2)) + ((or (integer -1 0) (integer 3 4)) . (or (integer -1 0) (integer 3 4))) + ((or (integer -1 2) (integer 3 4)) . (integer -1 4)) + ((or (integer -1 3) (integer 3 4)) . (integer -1 4)) + ((or (integer -1 4) (integer 3 4)) . (integer -1 4)) + ((or (integer -1 5) (integer 3 4)) . (integer -1 5)) + ((or (integer -1 *) (integer 3 4)) . (integer -1 *)) + ((or (integer -1 2) (integer * 4)) . (integer * 4))) "Alist type specifier -> expected type specifier.") (defmacro comp-cstr-synthesize-tests () diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index dd642b6a66..88c7b8c0d8 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -970,20 +970,7 @@ Return a list of results." ;; Range propagation tests. ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(comp-deftest range-simple-union () - (should (equal (comp-range-union '((-1 . 0)) '((3 . 4))) - '((-1 . 0) (3 . 4)))) - (should (equal (comp-range-union '((-1 . 2)) '((3 . 4))) - '((-1 . 4)))) - (should (equal (comp-range-union '((-1 . 3)) '((3 . 4))) - '((-1 . 4)))) - (should (equal (comp-range-union '((-1 . 4)) '((3 . 4))) - '((-1 . 4)))) - (should (equal (comp-range-union '((-1 . 5)) '((3 . 4))) - '((-1 . 5)))) - (should (equal (comp-range-union '((-1 . 0)) '()) - '((-1 . 0))))) - +;; FIXME to be removed when movable into comp-cstr-tests.el (comp-deftest range-simple-intersection () (should (equal (comp-range-intersection '((-1 . 0)) '((3 . 4))) '())) @@ -998,50 +985,4 @@ Return a list of results." (should (equal (comp-range-intersection '((-1 . 0)) '()) '()))) -(comp-deftest union-types () - (let ((comp-ctxt (make-comp-ctxt))) - (should (equal (comp-union-typesets '(integer) '(number)) - '(number))) - (should (equal (comp-union-typesets '(integer symbol) '(number)) - '(symbol number))) - (should (equal (comp-union-typesets '(integer symbol) '(number list)) - '(list symbol number))) - (should (equal (comp-union-typesets '(integer symbol) '()) - '(symbol integer))))) - -(comp-deftest destructure-type-spec () - (should (equal (comp-type-spec-to-constraint 'symbol) - (make-comp-constraint :typeset '(symbol)))) - (should (equal (comp-type-spec-to-constraint '(or symbol number)) - (make-comp-constraint :typeset '(number symbol)))) - (should-error (comp-type-spec-to-constraint '(symbol number))) - (should (equal (comp-type-spec-to-constraint '(member foo bar)) - (make-comp-constraint :typeset nil :valset '(foo bar)))) - (should (equal (comp-type-spec-to-constraint '(integer 1 2)) - (make-comp-constraint :typeset nil :range '((1 . 2))))) - (should (equal (comp-type-spec-to-constraint '(or (integer 1 2) (integer 4 5))) - (make-comp-constraint :typeset nil :range '((4 . 5) (1 . 2))))) - (should (equal (comp-type-spec-to-constraint '(integer * 2)) - (make-comp-constraint :typeset nil :range '((- . 2))))) - (should (equal (comp-type-spec-to-constraint '(integer 1 *)) - (make-comp-constraint :typeset nil :range '((1 . +))))) - (should (equal (comp-type-spec-to-constraint '(integer * *)) - (make-comp-constraint :typeset nil :range '((- . +))))) - (should (equal (comp-type-spec-to-constraint '(or (integer 1 2) - (member foo bar))) - (make-comp-constraint :typeset nil - :valset '(foo bar) - :range '((1 . 2))))) - (should (equal (comp-type-spec-to-constraint - '(function (t t) cons)) - (make-comp-constraint-f - :args `(,(make-comp-constraint :typeset '(t)) - ,(make-comp-constraint :typeset '(t))) - :ret (make-comp-constraint :typeset '(cons))))) - (should (equal (comp-type-spec-to-constraint - '(function ((or integer symbol)) float)) - (make-comp-constraint-f - :args `(,(make-comp-constraint :typeset '(symbol integer))) - :ret (make-comp-constraint :typeset '(float)))))) - ;;; comp-tests.el ends here commit 23c082638e77219b51e14797a0edae27ae59a9d6 Author: Andrea Corallo Date: Mon Nov 23 23:51:17 2020 +0100 Add comp-cstr.el and comp-cstr-tests.el As the constraint logic of the compiler is not trivial and largely independent from the rest of the code move it into comp-cstr.el to ease separation and maintainability. This commit improve the conversion type specifier -> constraint for generality. Lastly this should help with bootstrap time as comp.el compilation unit is slimmed down. * lisp/emacs-lisp/comp-cstr.el: New file. (comp--typeof-types, comp--all-builtin-types): Move from comp.el. (comp-cstr, comp-cstr-f): Same + rename. (comp-cstr-ctxt): New struct. (comp-supertypes, comp-common-supertype-2) (comp-common-supertype, comp-subtype-p, comp-union-typesets) (comp-range-1+, comp-range-1-, comp-range-<, comp-range-union) (comp-range-intersection): Move from comp.el. (comp-cstr-union-no-range, comp-cstr-union): Move from comp.el and rename. (comp-cstr-union-make): New function. (comp-type-spec-to-cstr, comp-cstr-to-type-spec): Move from comp.el, rename it and rework it. * lisp/emacs-lisp/comp.el (comp-known-func-cstr-h): Rework. (comp-ctxt): Remove two fields and include `comp-cstr-ctxt'. (comp-mvar, comp-fwprop-call): Update for `comp-cstr' being renamed. (comp-fwprop-insn): Use `comp-cstr-union-no-range' or `comp-cstr-union'. (comp-ret-type-spec): Use `comp-cstr-union' and rework. * test/lisp/emacs-lisp/comp-cstr-tests.el: New file. (comp-cstr-test-ts, comp-cstr-typespec-test): New functions. (comp-cstr-typespec-tests-alist): New defconst to generate tests on. (comp-cstr-generate-tests): New macro. * test/src/comp-tests.el (comp-tests-type-spec-tests): Update. (ret-type-spec): Initialize constraint context. diff --git a/lisp/Makefile.in b/lisp/Makefile.in index d6bb4cf557..5fec921b07 100644 --- a/lisp/Makefile.in +++ b/lisp/Makefile.in @@ -114,6 +114,7 @@ COMPILE_FIRST = \ $(lisp)/emacs-lisp/bytecomp.elc ifeq ($(HAVE_NATIVE_COMP),yes) COMPILE_FIRST += $(lisp)/emacs-lisp/comp.elc +COMPILE_FIRST += $(lisp)/emacs-lisp/comp-cstr.elc endif COMPILE_FIRST += $(lisp)/emacs-lisp/autoload.elc diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el new file mode 100644 index 0000000000..fcbb32fab2 --- /dev/null +++ b/lisp/emacs-lisp/comp-cstr.el @@ -0,0 +1,363 @@ +;;; comp-cstr.el --- native compiler constraint library -*- lexical-binding: t -*- + +;; Author: Andrea Corallo + +;; Copyright (C) 2020 Free Software Foundation, Inc. + +;; Keywords: lisp +;; Package: emacs + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;; Constraint library in use by the native compiler. + +;; In LIMPLE each non immediate value is represented by a `comp-mvar'. +;; The part concerning the set of all values the `comp-mvar' can +;; assume is described into its constraint `comp-cstr'. Each +;; constraint consists in a triplet: type-set, value-set, range-set. +;; This file provide set operations between constraints (union +;; intersection and negation) plus routines to convert from and to a +;; CL like type specifier. + +;;; Code: + +(require 'cl-lib) + +(defconst comp--typeof-types (mapcar (lambda (x) + (append x '(t))) + cl--typeof-types) + ;; TODO can we just add t in `cl--typeof-types'? + "Like `cl--typeof-types' but with t as common supertype.") + +(defconst comp--all-builtin-types + (append cl--all-builtin-types '(t)) + "Likewise like `cl--all-builtin-types' but with t as common supertype.") + +(cl-defstruct (comp-cstr (:constructor comp-type-to-cstr + (type &aux (typeset (list type)))) + (:constructor comp-value-to-cstr + (value &aux + (valset (list value)) + (typeset ()))) + (:constructor comp-irange-to-cstr + (irange &aux + (range (list irange)) + (typeset ())))) + "Internal representation of a type/value constraint." + (typeset '(t) :type list + :documentation "List of possible types the mvar can assume. +Each element cannot be a subtype of any other element of this slot.") + (valset () :type list + :documentation "List of possible values the mvar can assume. +Integer values are handled in the `range' slot.") + (range () :type list + :documentation "Integer interval.")) + +(cl-defstruct comp-cstr-f + "Internal constraint representation for a function." + (args () :type list + :documentation "List of `comp-cstr' for its arguments.") + (ret nil :type (or comp-cstr comp-cstr-f) + :documentation "Returned value.")) + +(cl-defstruct comp-cstr-ctxt + (union-typesets-mem (make-hash-table :test #'equal) :type hash-table + :documentation "Serve memoization for +`comp-union-typesets'.") + ;; TODO we should be able to just cons hash this. + (common-supertype-mem (make-hash-table :test #'equal) :type hash-table + :documentation "Serve memoization for +`comp-common-supertype'.")) + + +;;; Type handling. + +(defun comp-supertypes (type) + "Return a list of pairs (supertype . hierarchy-level) for TYPE." + (cl-loop + named outer + with found = nil + for l in comp--typeof-types + do (cl-loop + for x in l + for i from (length l) downto 0 + when (eq type x) + do (setf found t) + when found + collect `(,x . ,i) into res + finally (when found + (cl-return-from outer res))))) + +(defun comp-common-supertype-2 (type1 type2) + "Return the first common supertype of TYPE1 TYPE2." + (when-let ((types (cl-intersection + (comp-supertypes type1) + (comp-supertypes type2) + :key #'car))) + (car (cl-reduce (lambda (x y) + (if (> (cdr x) (cdr y)) x y)) + types)))) + +(defun comp-common-supertype (&rest types) + "Return the first common supertype of TYPES." + (or (gethash types (comp-cstr-ctxt-common-supertype-mem comp-ctxt)) + (puthash types + (cl-reduce #'comp-common-supertype-2 types) + (comp-cstr-ctxt-common-supertype-mem comp-ctxt)))) + +(defsubst comp-subtype-p (type1 type2) + "Return t if TYPE1 is a subtype of TYPE2 or nil otherwise." + (eq (comp-common-supertype-2 type1 type2) type2)) + +(defun comp-union-typesets (&rest typesets) + "Union types present into TYPESETS." + (or (gethash typesets (comp-cstr-ctxt-union-typesets-mem comp-ctxt)) + (puthash typesets + (cl-loop + with types = (apply #'append typesets) + with res = '() + for lane in comp--typeof-types + do (cl-loop + with last = nil + for x in lane + when (memq x types) + do (setf last x) + finally (when last + (push last res))) + ;; TODO sort. + finally (cl-return (cl-remove-duplicates res))) + (comp-cstr-ctxt-union-typesets-mem comp-ctxt)))) + + +;;; Integer range handling + +(defsubst comp-range-1+ (x) + (if (symbolp x) + x + (1+ x))) + +(defsubst comp-range-1- (x) + (if (symbolp x) + x + (1- x))) + +(defsubst comp-range-< (x y) + (cond + ((eq x '+) nil) + ((eq x '-) t) + ((eq y '+) t) + ((eq y '-) nil) + (t (< x y)))) + +(defun comp-range-union (&rest ranges) + "Combine integer intervals RANGES by union set operation." + (cl-loop + with all-ranges = (apply #'append ranges) + with lows = (mapcar (lambda (x) + (cons (comp-range-1- (car x)) 'l)) + all-ranges) + with highs = (mapcar (lambda (x) + (cons (cdr x) 'h)) + all-ranges) + with nest = 0 + with low = nil + with res = () + for (i . x) in (cl-sort (nconc lows highs) #'comp-range-< :key #'car) + if (eq x 'l) + do + (when (zerop nest) + (setf low i)) + (cl-incf nest) + else + do + (when (= nest 1) + (push `(,(comp-range-1+ low) . ,i) res)) + (cl-decf nest) + finally (cl-return (reverse res)))) + +(defun comp-range-intersection (&rest ranges) + "Combine integer intervals RANGES by intersecting." + (cl-loop + with all-ranges = (apply #'append ranges) + with n-ranges = (length ranges) + with lows = (mapcar (lambda (x) + (cons (car x) 'l)) + all-ranges) + with highs = (mapcar (lambda (x) + (cons (cdr x) 'h)) + all-ranges) + with nest = 0 + with low = nil + with res = () + initially (when (cl-some #'null ranges) + ;; Intersecting with a null range always results in a + ;; null range. + (cl-return '())) + for (i . x) in (cl-sort (nconc lows highs) #'comp-range-< :key #'car) + if (eq x 'l) + do + (cl-incf nest) + (when (= nest n-ranges) + (setf low i)) + else + do + (when (= nest n-ranges) + (push `(,low . ,i) + res)) + (cl-decf nest) + finally (cl-return (reverse res)))) + + +;;; Entry points. + +(defun comp-cstr-union-no-range (dst &rest srcs) + "As `comp-cstr-union' but escluding the irange component." + (let ((values (mapcar #'comp-cstr-valset srcs))) + + ;; Type propagation. + (setf (comp-cstr-typeset dst) + (apply #'comp-union-typesets (mapcar #'comp-cstr-typeset srcs))) + + ;; Value propagation. + (setf (comp-cstr-valset dst) + (cl-loop + ;; TODO sort. + for v in (cl-remove-duplicates (apply #'append values) + :test #'equal) + ;; We propagate only values those types are not already + ;; into typeset. + when (cl-notany (lambda (x) + (comp-subtype-p (type-of v) x)) + (comp-cstr-typeset dst)) + collect v)) + + dst)) + +(defun comp-cstr-union (dst &rest srcs) + "Combine SRCS by union set operation setting the result in DST. +DST is returned." + (apply #'comp-cstr-union-no-range dst srcs) + ;; Range propagation + (setf (comp-cstr-range dst) + (when (cl-notany (lambda (x) + (comp-subtype-p 'integer x)) + (comp-cstr-typeset dst)) + ;; TODO memoize? + (apply #'comp-range-union + (mapcar #'comp-cstr-range srcs)))) + dst) + +(defun comp-cstr-union-make (&rest srcs) + "Combine SRCS by union set operation and return a new constraint." + (apply #'comp-cstr-union (make-comp-cstr) srcs)) + +(defun comp-type-spec-to-cstr (type-spec &optional fn) + "Convert a type specifier TYPE-SPEC into a `comp-cstr'. +FN non-nil indicates we are parsing a function lambda list." + (cl-flet ((star-or-num (x) + (or (numberp x) (eq '* x)))) + (pcase type-spec + ((and (or '&optional '&rest) x) + (if fn + x + (error "Invalid `%s` in type specifier" x))) + ('fixnum + (comp-irange-to-cstr `(,most-negative-fixnum . ,most-positive-fixnum))) + ('boolean + (comp-type-spec-to-cstr '(member t nil))) + ('null (comp-value-to-cstr nil)) + ((pred atom) + (comp-type-to-cstr type-spec)) + (`(or . ,rest) + (apply #'comp-cstr-union-make + (mapcar #'comp-type-spec-to-cstr rest))) + (`(and . ,rest) + (cl-assert nil) + ;; TODO + ;; (apply #'comp-cstr-intersect-make + ;; (mapcar #'comp-type-spec-to-cstr rest)) + ) + (`(not ,cstr) + (cl-assert nil) + ;; TODO + ;; (comp-cstr-negate-make (comp-type-spec-to-cstr cstr)) + ) + (`(integer ,(and (pred integerp) l) ,(and (pred integerp) h)) + (comp-irange-to-cstr `(,l . ,h))) + (`(integer * ,(and (pred integerp) h)) + (comp-irange-to-cstr `(- . ,h))) + (`(integer ,(and (pred integerp) l) *) + (comp-irange-to-cstr `(,l . +))) + (`(float ,(pred star-or-num) ,(pred star-or-num)) + ;; No float range support :/ + (comp-type-to-cstr 'float)) + (`(member . ,rest) + (apply #'comp-cstr-union-make (mapcar #'comp-value-to-cstr rest))) + (`(function ,args ,ret) + (make-comp-cstr-f + :args (mapcar (lambda (x) + (comp-type-spec-to-cstr x t)) + args) + :ret (comp-type-spec-to-cstr ret))) + (_ (error "Invalid type specifier"))))) + +(defun comp-cstr-to-type-spec (cstr) + "Given CSTR return its type specifier." + (let ((valset (comp-cstr-valset cstr)) + (typeset (comp-cstr-typeset cstr)) + (range (comp-cstr-range cstr))) + + (when valset + (when (memq nil valset) + (if (memq t valset) + (progn + ;; t and nil are values, convert into `boolean'. + (push 'boolean typeset) + (setf valset (remove t (remove nil valset)))) + ;; Only nil is a value, convert it into a `null' type specifier. + (setf valset (remove nil valset)) + (push 'null typeset)))) + + ;; Form proper integer type specifiers. + (setf range (cl-loop for (l . h) in range + for low = (if (integerp l) l '*) + for high = (if (integerp h) h '*) + collect `(integer ,low , high)) + valset (cl-remove-duplicates valset)) + + ;; Form the final type specifier. + (let* ((types-ints (append typeset range)) + (res (cond + ((and types-ints valset) + `((member ,@valset) ,@types-ints)) + (types-ints types-ints) + (valset `(member ,@valset)) + (t + ;; Empty type specifier + nil)))) + (pcase res + (`(,(or 'integer 'member) . ,_rest) res) + ((pred atom) res) + (`(,_first . ,rest) + (if rest + `(or ,@res) + (car res))))))) + +(provide 'comp-cstr) + +;;; comp-cstr.el ends here diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 5313bfba99..498aae183a 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -38,6 +38,7 @@ (require 'rx) (require 'subr-x) (require 'warnings) +(require 'comp-cstr) (defgroup comp nil "Emacs Lisp native compiler." @@ -267,6 +268,16 @@ Useful to hook into pass checkers.") (comp-hint-cons (function (t) cons))) "Alist used for type propagation.") +(defconst comp-known-func-cstr-h + (cl-loop + with comp-ctxt = (make-comp-cstr-ctxt) + with h = (make-hash-table :test #'eq) + for (f type-spec) in comp-known-type-specifiers + for cstr = (comp-type-spec-to-cstr type-spec) + do (puthash f cstr h) + finally (cl-return h)) + "Hash table function -> `comp-constraint'") + (defconst comp-symbol-values-optimizable '(most-positive-fixnum most-negative-fixnum) "Symbol values we can resolve in the compile-time.") @@ -326,7 +337,7 @@ Useful to hook into pass checkers.") (idx (make-hash-table :test #'equal) :type hash-table :documentation "Obj -> position into the previous field.")) -(cl-defstruct comp-ctxt +(cl-defstruct (comp-ctxt (:include comp-cstr-ctxt)) "Lisp side of the compiler context." (output nil :type string :documentation "Target output file-name for the compilation.") @@ -356,13 +367,7 @@ This is typically for top-level forms other than defun.") (d-ephemeral (make-comp-data-container) :type comp-data-container :documentation "Relocated data not necessary after load.") (with-late-load nil :type boolean - :documentation "When non-nil support late load.") - (union-typesets-mem (make-hash-table :test #'equal) :type hash-table - :documentation "Serve memoization for -`comp-union-typesets'.") - (common-supertype-mem (make-hash-table :test #'equal) :type hash-table - :documentation "Serve memoization for -`comp-common-supertype'.")) + :documentation "When non-nil support late load.")) (cl-defstruct comp-args-base (min nil :type number @@ -489,26 +494,8 @@ CFG is mutated by a pass.") (lambda-list nil :type list :documentation "Original lambda-list.")) -(cl-defstruct comp-constraint - "Internal representation of a type/value constraint." - (typeset '(t) :type list - :documentation "List of possible types the mvar can assume. -Each element cannot be a subtype of any other element of this slot.") - (valset '() :type list - :documentation "List of possible values the mvar can assume. -Integer values are handled in the `range' slot.") - (range '() :type list - :documentation "Integer interval.")) - -(cl-defstruct comp-constraint-f - "Internal constraint representation for a function." - (args nil :type (or null list) - :documentation "List of `comp-constraint' for its arguments.") - (ret nil :type (or comp-constraint comp-constraint-f) - :documentation "Returned value `comp-constraint'.")) - (cl-defstruct (comp-mvar (:constructor make--comp-mvar) - (:include comp-constraint)) + (:include comp-cstr)) "A meta-variable being a slot in the meta-stack." (id nil :type (or null number) :documentation "Unique id when in SSA form.") @@ -592,108 +579,6 @@ To be used by all entry points." ((null (native-comp-available-p)) (error "Cannot find libgccjit")))) -(cl-defun comp-type-spec-to-constraint (type-specifier) - "Destructure TYPE-SPECIFIER. -Return the corresponding `comp-constraint' or `comp-constraint-f'." - (let (typeset valset range) - (cl-labels ((star-or-num (x) - (or (numberp x) (eq '* x))) - (destructure-push (x) - (pcase x - ('&optional - (cl-return-from comp-type-spec-to-constraint '&optional)) - ('&rest - (cl-return-from comp-type-spec-to-constraint '&rest)) - ('null - (push nil valset)) - ('boolean - (push t valset) - (push nil valset)) - ('fixnum - (push `(,most-negative-fixnum . ,most-positive-fixnum) - range)) - ('bignum - (push `(- . ,(1- most-negative-fixnum)) - range) - (push `(,(1+ most-positive-fixnum) . +) - range)) - ((pred symbolp) - (push x typeset)) - (`(member . ,rest) - (setf valset (append rest valset))) - ('(integer * *) - (push '(- . +) range)) - (`(integer ,(and low (pred integerp)) *) - (push `(,low . +) range)) - (`(integer * ,(and high (pred integerp))) - (push `(- . ,high) range)) - (`(integer ,(and low (pred integerp)) - ,(and high (pred integerp))) - (push `(,low . ,high) range)) - (`(float ,(pred star-or-num) ,(pred star-or-num)) - ;; No float range support :/ - (push 'float typeset)) - (`(function ,args ,ret-type-spec) - (cl-return-from - comp-type-spec-to-constraint - (make-comp-constraint-f - :args (mapcar #'comp-type-spec-to-constraint args) - :ret (comp-type-spec-to-constraint ret-type-spec)))) - (_ (error "Unsopported type specifier"))))) - (if (or (atom type-specifier) - (memq (car type-specifier) '(member integer float function))) - (destructure-push type-specifier) - (if (eq (car type-specifier) 'or) - (mapc #'destructure-push (cdr type-specifier)) - (error "Unsopported type specifier"))) - (make-comp-constraint :typeset typeset - :valset valset - :range range)))) - -(defconst comp-known-constraints-h - (let ((h (make-hash-table :test #'eq))) - (cl-loop - for (f type-spec) in comp-known-type-specifiers - for constr = (comp-type-spec-to-constraint type-spec) - do (puthash f constr h)) - h) - "Hash table function -> `comp-constraint'") - -(defun comp-constraint-to-type-spec (mvar) - "Given MVAR return its type specifier." - (let ((valset (comp-mvar-valset mvar)) - (typeset (comp-mvar-typeset mvar)) - (range (comp-mvar-range mvar))) - - (when valset - (when (memq nil valset) - (if (memq t valset) - (progn - ;; t and nil are values, convert into `boolean'. - (push 'boolean typeset) - (setf valset (remove t (remove nil valset)))) - ;; Only nil is a value, convert it into a `null' type specifier. - (setf valset (remove nil valset)) - (push 'null typeset)))) - - ;; Form proper integer type specifiers. - (setf range (cl-loop for (l . h) in range - for low = (if (integerp l) l '*) - for high = (if (integerp h) h '*) - collect `(integer ,low , high)) - valset (cl-remove-duplicates valset)) - - ;; Form the final type specifier. - (let ((res (append typeset - (when valset - `((member ,@valset))) - range))) - (if (> (length res) 1) - `(or ,@res) - (if (memq (car-safe res) '(member integer)) - res - (car res)))))) - (defun comp-set-op-p (op) "Assignment predicate for OP." (when (memq op comp-limple-sets) t)) @@ -2392,143 +2277,6 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non-nil." ;; This is also responsible for removing function calls to pure functions if ;; possible. -(defconst comp--typeof-types (mapcar (lambda (x) - (append x '(t))) - cl--typeof-types) - ;; TODO can we just add t in `cl--typeof-types'? - "Like `cl--typeof-types' but with t as common supertype.") - -(defun comp-supertypes (type) - "Return a list of pairs (supertype . hierarchy-level) for TYPE." - (cl-loop - named outer - with found = nil - for l in comp--typeof-types - do (cl-loop - for x in l - for i from (length l) downto 0 - when (eq type x) - do (setf found t) - when found - collect `(,x . ,i) into res - finally (when found - (cl-return-from outer res))))) - -(defun comp-common-supertype-2 (type1 type2) - "Return the first common supertype of TYPE1 TYPE2." - (when-let ((types (cl-intersection - (comp-supertypes type1) - (comp-supertypes type2) - :key #'car))) - (car (cl-reduce (lambda (x y) - (if (> (cdr x) (cdr y)) x y)) - types)))) - -(defun comp-common-supertype (&rest types) - "Return the first common supertype of TYPES." - (or (gethash types (comp-ctxt-common-supertype-mem comp-ctxt)) - (puthash types - (cl-reduce #'comp-common-supertype-2 types) - (comp-ctxt-common-supertype-mem comp-ctxt)))) - -(defsubst comp-subtype-p (type1 type2) - "Return t if TYPE1 is a subtype of TYPE1 or nil otherwise." - (eq (comp-common-supertype-2 type1 type2) type2)) - -(defun comp-union-typesets (&rest typesets) - "Union types present into TYPESETS." - (or (gethash typesets (comp-ctxt-union-typesets-mem comp-ctxt)) - (puthash typesets - (cl-loop - with types = (apply #'append typesets) - with res = '() - for lane in comp--typeof-types - do (cl-loop - with last = nil - for x in lane - when (memq x types) - do (setf last x) - finally (when last - (push last res))) - finally (cl-return (cl-remove-duplicates res))) - (comp-ctxt-union-typesets-mem comp-ctxt)))) - -(defsubst comp-range-1+ (x) - (if (symbolp x) - x - (1+ x))) - -(defsubst comp-range-1- (x) - (if (symbolp x) - x - (1- x))) - -(defsubst comp-range-< (x y) - (cond - ((eq x '+) nil) - ((eq x '-) t) - ((eq y '+) t) - ((eq y '-) nil) - (t (< x y)))) - -(defun comp-range-union (&rest ranges) - "Combine integer intervals RANGES by union operation." - (cl-loop - with all-ranges = (apply #'append ranges) - with lows = (mapcar (lambda (x) - (cons (comp-range-1- (car x)) 'l)) - all-ranges) - with highs = (mapcar (lambda (x) - (cons (cdr x) 'h)) - all-ranges) - with nest = 0 - with low = nil - with res = () - for (i . x) in (cl-sort (nconc lows highs) #'comp-range-< :key #'car) - if (eq x 'l) - do - (when (zerop nest) - (setf low i)) - (cl-incf nest) - else - do - (when (= nest 1) - (push `(,(comp-range-1+ low) . ,i) res)) - (cl-decf nest) - finally (cl-return (reverse res)))) - -(defun comp-range-intersection (&rest ranges) - "Combine integer intervals RANGES by intersecting." - (cl-loop - with all-ranges = (apply #'append ranges) - with n-ranges = (length ranges) - with lows = (mapcar (lambda (x) - (cons (car x) 'l)) - all-ranges) - with highs = (mapcar (lambda (x) - (cons (cdr x) 'h)) - all-ranges) - with nest = 0 - with low = nil - with res = () - initially (when (cl-some #'null ranges) - ;; Intersecting with a null range always results in a - ;; null range. - (cl-return '())) - for (i . x) in (cl-sort (nconc lows highs) #'comp-range-< :key #'car) - if (eq x 'l) - do - (cl-incf nest) - (when (= nest n-ranges) - (setf low i)) - else - do - (when (= nest n-ranges) - (push `(,low . ,i) - res)) - (cl-decf nest) - finally (cl-return (reverse res)))) - (defun comp-copy-insn (insn) "Deep copy INSN." ;; Adapted from `copy-tree'. @@ -2615,55 +2363,16 @@ Return non-nil if the function is folded successfully." (value (comp-apply-in-env f (mapcar #'comp-mvar-value args)))) (rewrite-insn-as-setimm insn value))))))) -(defun comp-phi (lval &rest rvals) - "Phi function propagating RVALS into LVAL. -Return LVAL." - (let* ((rhs-mvars (mapcar #'car rvals)) - (values (mapcar #'comp-mvar-valset rhs-mvars)) - (from-latch (cl-some - (lambda (x) - (comp-latch-p - (gethash (cdr x) - (comp-func-blocks comp-func)))) - rvals))) - - ;; Type propagation. - (setf (comp-mvar-typeset lval) - (apply #'comp-union-typesets (mapcar #'comp-mvar-typeset rhs-mvars))) - - ;; Value propagation. - (setf (comp-mvar-valset lval) - (cl-loop - for v in (cl-remove-duplicates (apply #'append values) - :test #'equal) - ;; We propagate only values those types are not already - ;; into typeset. - when (cl-notany (lambda (x) - (comp-subtype-p (type-of v) x)) - (comp-mvar-typeset lval)) - collect v)) - - ;; Range propagation - (setf (comp-mvar-range lval) - (when (and (not from-latch) - (cl-notany (lambda (x) - (comp-subtype-p 'integer x)) - (comp-mvar-typeset lval))) - ;; TODO memoize? - (apply #'comp-range-union - (mapcar #'comp-mvar-range rhs-mvars)))) - lval)) - (defun comp-fwprop-call (insn lval f args) "Propagate on a call INSN into LVAL. F is the function being called with arguments ARGS. Fold the call in case." (unless (comp-function-call-maybe-fold insn f args) - (when-let ((constr (gethash f comp-known-constraints-h))) - (let ((constr (comp-constraint-f-ret constr))) - (setf (comp-mvar-range lval) (comp-constraint-range constr) - (comp-mvar-valset lval) (comp-constraint-valset constr) - (comp-mvar-typeset lval) (comp-constraint-typeset constr)))))) + (when-let ((cstr-f (gethash f comp-known-func-cstr-h))) + (let ((cstr (comp-cstr-f-ret cstr-f))) + (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)))))) (defun comp-fwprop-insn (insn) "Propagate within INSN." @@ -2695,7 +2404,17 @@ Fold the call in case." (`(setimm ,lval ,v) (setf (comp-mvar-value lval) v)) (`(phi ,lval . ,rest) - (apply #'comp-phi lval rest)))) + (let* ((from-latch (cl-some + (lambda (x) + (comp-latch-p + (gethash (cdr x) + (comp-func-blocks comp-func)))) + rest)) + (prop-fn (if from-latch + #'comp-cstr-union-no-range + #'comp-cstr-union)) + (rvals (mapcar #'car rest))) + (apply prop-fn lval rvals))))) (defun comp-fwprop* () "Propagate for set* and phi operands. @@ -2966,8 +2685,8 @@ These are substituted with a normal 'set' op." "Compute type specifier for `comp-func' FUNC. Set it into the `ret-type-specifier' slot." (let* ((comp-func (make-comp-func)) - (res-mvar (apply #'comp-phi - (make-comp-mvar) + (res-mvar (apply #'comp-cstr-union + (make-comp-cstr) (cl-loop with res = nil for bb being the hash-value in (comp-func-blocks @@ -2978,10 +2697,10 @@ Set it into the `ret-type-specifier' slot." ;; mvars and union results. do (pcase insn (`(return ,mvar) - (push `(,mvar . nil) res)))) + (push mvar res)))) finally (cl-return res))))) (setf (comp-func-ret-type-specifier func) - (comp-constraint-to-type-spec res-mvar)))) + (comp-cstr-to-type-spec res-mvar)))) (defun comp-finalize-container (cont) "Finalize data container CONT." diff --git a/test/lisp/emacs-lisp/comp-cstr-tests.el b/test/lisp/emacs-lisp/comp-cstr-tests.el new file mode 100644 index 0000000000..74419ff01e --- /dev/null +++ b/test/lisp/emacs-lisp/comp-cstr-tests.el @@ -0,0 +1,68 @@ +;;; comp-cstr-tests.el --- unit tests for src/comp.c -*- lexical-binding: t; -*- + +;; Copyright (C) 2020 Free Software Foundation, Inc. + +;; Author: Andrea Corallo + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;; Unit tests for lisp/emacs-lisp/comp-cstr.el + +;;; Code: + +(require 'ert) +(require 'cl-lib) +(require 'comp-cstr) + +(defun comp-cstr-test-ts (type-spec) + "Create a constraint from TYPE-SPEC and convert it back to type specifier." + (let ((comp-ctxt (make-comp-cstr-ctxt))) + (comp-cstr-to-type-spec (comp-type-spec-to-cstr type-spec)))) + +(defun comp-cstr-typespec-test (number type-spec expected-type-spec) + `(ert-deftest ,(intern (concat "comp-cstr-test-" (int-to-string number))) () + (should (equal (comp-cstr-test-ts ',type-spec) + ',expected-type-spec)))) + +(defconst comp-cstr-typespec-tests-alist + `((symbol . symbol) + ((or string array) . array) + ;; ((and string array) . string) + ((or symbol number) . (or symbol number)) + ((or cons atom) . (or cons atom)) ;; SBCL return T + ;; ((and cons atom) . (or cons atom)) + ((member foo) . (member foo)) + ((member foo bar) . (member foo bar)) + ((or (member foo) (member bar)) . (member foo bar)) + ;; ((and (member foo) (member bar)) . symbol) + ((or (member foo) symbol) . symbol) ;; SBCL return (OR SYMBOL (MEMBER FOO)) + ;; ((and (member foo) symbol) . (member foo)) + ((or (member foo) number) . (or (member foo) number))) + "Alist type specifier -> expected type specifier.") + +(defmacro comp-cstr-synthesize-tests () + "Generate all tests from `comp-cstr-typespec-tests-alist'." + `(progn + ,@(cl-loop + for i from 0 + for (ts . exp-ts) in comp-cstr-typespec-tests-alist + append (list (comp-cstr-typespec-test i ts exp-ts))))) + +(comp-cstr-synthesize-tests) + +;;; comp-cstr-tests.el ends here diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index fffc72015b..dd642b6a66 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -855,10 +855,10 @@ Return a list of results." (if (= x y) x 'foo)) - (or number (member foo))) + (or (member foo) number)) ((defun comp-tests-ret-type-spec-9-1-f (x) - (comp-hint-fixnum y)) + (comp-hint-fixnum x)) (integer ,most-negative-fixnum ,most-positive-fixnum)) ((defun comp-tests-ret-type-spec-f (x) @@ -892,7 +892,8 @@ Return a list of results." (comp-deftest ret-type-spec () "Some derived return type specifier tests." - (cl-loop for (func-form type-spec) in comp-tests-type-spec-tests + (cl-loop with comp-ctxt = (make-comp-cstr-ctxt) + for (func-form type-spec) in comp-tests-type-spec-tests do (comp-tests-check-ret-type-spec func-form type-spec))) (defun comp-tests-pure-checker-1 (_) commit 7a8370ed0f1b1d62657e385789ee2f81c5607ec5 Author: Andrea Corallo Date: Mon Nov 23 20:26:00 2020 +0100 * Add SELECTOR parameter to `native-compile-async' (bug#44813) * lisp/emacs-lisp/comp.el (native-compile-async-skip-p): New function ripping out logic from `native--compile-async' and accounting for SELECTOR. (native--compile-async): Add SELECTOR parameter, make use of `native-compile-async-skip-p' and move it with other private functions. (native-compile-async): Add SELECTOR parameter. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 29a97a7196..5313bfba99 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -3439,53 +3439,26 @@ load once finished compiling." ;; So we return the compiled function. (native-elisp-load data)))) - -;;; Compiler entry points. - -;;;###autoload -(defun native-compile (function-or-file &optional output) - "Compile FUNCTION-OR-FILE into native code. -This is the synchronous entry-point for the Emacs Lisp native -compiler. -FUNCTION-OR-FILE is a function symbol, a form or the filename of -an Emacs Lisp source file. -When OUTPUT is non-nil use it as filename for the compiled -object. -If FUNCTION-OR-FILE is a filename return the filename of the -compiled object. If FUNCTION-OR-FILE is a function symbol or a -form return the compiled function." - (comp--native-compile function-or-file nil output)) - -;;;###autoload -(defun batch-native-compile () - "Run `native-compile' on remaining command-line arguments. -Ultra cheap impersonation of `batch-byte-compile'." - (comp-ensure-native-compiler) - (cl-loop for file in command-line-args-left - if (or (null byte-native-for-bootstrap) - (cl-notany (lambda (re) (string-match re file)) - comp-bootstrap-deny-list)) - do (comp--native-compile file) - else - do (byte-compile-file file))) - -;;;###autoload -(defun batch-byte-native-compile-for-bootstrap () - "As `batch-byte-compile' but used for booststrap. -Generate .elc files in addition to the .eln one. If the -environment variable 'NATIVE_DISABLED' is set byte compile only." - (comp-ensure-native-compiler) - (if (equal (getenv "NATIVE_DISABLED") "1") - (batch-byte-compile) - (cl-assert (= 1 (length command-line-args-left))) - (let ((byte-native-for-bootstrap 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)))))) - -(defun native--compile-async (paths &optional recursively load) +(defun native-compile-async-skip-p (file load selector) + "Return non-nil when FILE compilation should be skipped. + +LOAD and SELECTOR work as described in `native--compile-async'." + ;; Make sure we are not already compiling `file' (bug#40838). + (or (gethash file comp-async-compilations) + (cond + ((null selector) nil) + ((functionp selector) (not (funcall selector file))) + ((stringp selector) (not (string-match-p selector file))) + (t (error "SELECTOR must be a function a regexp or nil"))) + ;; Also exclude files from deferred compilation if + ;; any of the regexps in + ;; `comp-deferred-compilation-deny-list' matches. + (and (eq load 'late) + (cl-some (lambda (re) + (string-match-p re file)) + comp-deferred-compilation-deny-list)))) + +(defun native--compile-async (paths &optional recursively load selector) "Compile PATHS asynchronously. PATHS is one path or a list of paths to files or directories. @@ -3495,6 +3468,12 @@ subdirectories of given directories. If optional argument LOAD is non-nil, request to load the file after compiling. +The optional argument SELECTOR has the following valid values: + +nil -- Select all files. +a string -- A regular expression selecting files with matching names. +a function -- A function selecting files with matching names. + The variable `comp-async-jobs-number' specifies the number of (commands) to run simultaneously. @@ -3531,14 +3510,8 @@ bytecode definition was not changed in the meanwhile)." (eq load (cdr entry))) (cl-substitute (cons file load) (car entry) comp-files-queue :key #'car :test #'string=)) - ;; Make sure we are not already compiling `file' (bug#40838). - (unless (or (gethash file comp-async-compilations) - ;; Also exclude files from deferred compilation if - ;; any of the regexps in - ;; `comp-deferred-compilation-deny-list' matches. - (and (eq load 'late) - (cl-some (lambda (re) (string-match re file)) - comp-deferred-compilation-deny-list))) + + (unless (native-compile-async-skip-p file load selector) (let* ((out-filename (comp-el-to-eln-filename file)) (out-dir (file-name-directory out-filename))) (unless (file-exists-p out-dir) @@ -3552,8 +3525,54 @@ bytecode definition was not changed in the meanwhile)." (when (zerop (comp-async-runnings)) (comp-run-async-workers)))) + +;;; Compiler entry points. + +;;;###autoload +(defun native-compile (function-or-file &optional output) + "Compile FUNCTION-OR-FILE into native code. +This is the synchronous entry-point for the Emacs Lisp native +compiler. +FUNCTION-OR-FILE is a function symbol, a form or the filename of +an Emacs Lisp source file. +When OUTPUT is non-nil use it as filename for the compiled +object. +If FUNCTION-OR-FILE is a filename return the filename of the +compiled object. If FUNCTION-OR-FILE is a function symbol or a +form return the compiled function." + (comp--native-compile function-or-file nil output)) + +;;;###autoload +(defun batch-native-compile () + "Run `native-compile' on remaining command-line arguments. +Ultra cheap impersonation of `batch-byte-compile'." + (comp-ensure-native-compiler) + (cl-loop for file in command-line-args-left + if (or (null byte-native-for-bootstrap) + (cl-notany (lambda (re) (string-match re file)) + comp-bootstrap-deny-list)) + do (comp--native-compile file) + else + do (byte-compile-file file))) + +;;;###autoload +(defun batch-byte-native-compile-for-bootstrap () + "As `batch-byte-compile' but used for booststrap. +Generate .elc files in addition to the .eln one. If the +environment variable 'NATIVE_DISABLED' is set byte compile only." + (comp-ensure-native-compiler) + (if (equal (getenv "NATIVE_DISABLED") "1") + (batch-byte-compile) + (cl-assert (= 1 (length command-line-args-left))) + (let ((byte-native-for-bootstrap 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)))))) + ;;;###autoload -(defun native-compile-async (paths &optional recursively load) +(defun native-compile-async (paths &optional recursively load selector) "Compile PATHS asynchronously. PATHS is one path or a list of paths to files or directories. @@ -3563,11 +3582,17 @@ subdirectories of given directories. If optional argument LOAD is non-nil, request to load the file after compiling. +The optional argument SELECTOR has the following valid values: + +nil -- Select all files. +a string -- A regular expression selecting files with matching names. +a function -- A function selecting files with matching names. + The variable `comp-async-jobs-number' specifies the number of (commands) to run simultaneously." ;; Normalize: we only want to pass t or nil, never e.g. `late'. (let ((load (not (not load)))) - (native--compile-async paths recursively load))) + (native--compile-async paths recursively load selector))) (provide 'comp) commit 6104ab0f35e10c4d61c8e8774aa246e6630c8ac0 Author: Andrea Corallo Date: Mon Nov 23 20:25:00 2020 +0100 * Rename two native compiler customize * lisp/emacs-lisp/comp.el (comp-deferred-compilation-deny-list): Rename from `comp-deferred-compilation-black-list'. * lisp/emacs-lisp/comp.el (native--compile-async): Update to use `comp-deferred-compilation-deny-list'. (comp-bootstrap-deny-list): Rename. (batch-native-compile): Update to use `comp-bootstrap-deny-list'. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 567ff00b9c..29a97a7196 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -80,13 +80,13 @@ This intended for debugging the compiler itself. "Unconditionally (re-)compile all files." :type 'boolean) -(defcustom comp-deferred-compilation-black-list +(defcustom comp-deferred-compilation-deny-list '() "List of regexps to exclude files from deferred native compilation. Skip if any is matching." :type 'list) -(defcustom comp-bootstrap-black-list +(defcustom comp-bootstrap-deny-list '() "List of regexps to exclude files from native compilation during bootstrap. Skip if any is matching." @@ -3464,7 +3464,7 @@ Ultra cheap impersonation of `batch-byte-compile'." (cl-loop for file in command-line-args-left if (or (null byte-native-for-bootstrap) (cl-notany (lambda (re) (string-match re file)) - comp-bootstrap-black-list)) + comp-bootstrap-deny-list)) do (comp--native-compile file) else do (byte-compile-file file))) @@ -3535,10 +3535,10 @@ bytecode definition was not changed in the meanwhile)." (unless (or (gethash file comp-async-compilations) ;; Also exclude files from deferred compilation if ;; any of the regexps in - ;; `comp-deferred-compilation-black-list' matches. + ;; `comp-deferred-compilation-deny-list' matches. (and (eq load 'late) (cl-some (lambda (re) (string-match re file)) - comp-deferred-compilation-black-list))) + comp-deferred-compilation-deny-list))) (let* ((out-filename (comp-el-to-eln-filename file)) (out-dir (file-name-directory out-filename))) (unless (file-exists-p out-dir) commit 033e96055cc172d8d84adc128aee7f7d9889bb00 Merge: 6781cd670d 9b6ad3107f Author: Andrea Corallo Date: Sun Nov 22 22:23:16 2020 +0100 Merge remote-tracking branch 'savannah/master' into HEAD commit 6781cd670d1487bbf0364d80de68ca9733342769 Author: Stefan Kangas Date: Thu Nov 19 22:18:50 2020 +0100 Make load argument of native-compile-async internal * lisp/emacs-lisp/comp.el (native--compile-async): New defun extracted from native-compile-async. (native-compile-async): Remove load argument and use above new defun. * src/comp.c (maybe_defer_native_compilation): Use above new defun. (Bug#44676) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 2f1e8965c1..567ff00b9c 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -3485,8 +3485,7 @@ environment variable 'NATIVE_DISABLED' is set byte compile only." (`(,tempfile . ,target-file) (rename-file tempfile target-file t)))))) -;;;###autoload -(defun native-compile-async (paths &optional recursively load) +(defun native--compile-async (paths &optional recursively load) "Compile PATHS asynchronously. PATHS is one path or a list of paths to files or directories. @@ -3553,6 +3552,23 @@ bytecode definition was not changed in the meanwhile)." (when (zerop (comp-async-runnings)) (comp-run-async-workers)))) +;;;###autoload +(defun native-compile-async (paths &optional recursively load) + "Compile PATHS asynchronously. +PATHS is one path or a list of paths to files or directories. + +If optional argument RECURSIVELY is non-nil, recurse into +subdirectories of given directories. + +If optional argument LOAD is non-nil, request to load the file +after compiling. + +The variable `comp-async-jobs-number' specifies the number +of (commands) to run simultaneously." + ;; Normalize: we only want to pass t or nil, never e.g. `late'. + (let ((load (not (not load)))) + (native--compile-async paths recursively load))) + (provide 'comp) ;;; comp.el ends here diff --git a/src/comp.c b/src/comp.c index 6ddfad528b..99560cc13a 100644 --- a/src/comp.c +++ b/src/comp.c @@ -4677,13 +4677,13 @@ maybe_defer_native_compilation (Lisp_Object function_name, /* Comp already loaded. */ if (!NILP (delayed_sources)) { - CALLN (Ffuncall, intern_c_string ("native-compile-async"), + CALLN (Ffuncall, intern_c_string ("native--compile-async"), delayed_sources, Qnil, Qlate); delayed_sources = Qnil; } Fputhash (function_name, definition, Vcomp_deferred_pending_h); - CALLN (Ffuncall, intern_c_string ("native-compile-async"), src, Qnil, - Qlate); + CALLN (Ffuncall, intern_c_string ("native--compile-async"), + src, Qnil, Qlate); } else { commit c60355582a3ed19b4cc7e04b3b2031e461ccf7f1 Author: Stefan Kangas Date: Thu Nov 19 22:11:17 2020 +0100 * lisp/emacs-lisp/comp.el (native-compile-async): Doc fix. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 095bd63a10..2f1e8965c1 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -3489,13 +3489,28 @@ environment variable 'NATIVE_DISABLED' is set byte compile only." (defun native-compile-async (paths &optional recursively load) "Compile PATHS asynchronously. PATHS is one path or a list of paths to files or directories. -`comp-async-jobs-number' specifies the number of (commands) to -run simultaneously. If RECURSIVELY, recurse into subdirectories -of given directories. -LOAD can be nil t or 'late." + +If optional argument RECURSIVELY is non-nil, recurse into +subdirectories of given directories. + +If optional argument LOAD is non-nil, request to load the file +after compiling. + +The variable `comp-async-jobs-number' specifies the number +of (commands) to run simultaneously. + +LOAD can also be the symbol `late'. This is used internally if +the byte code has already been loaded when this function is +called. It means that we requests the special kind of load, +necessary in that situation, called \"late\" loading. + +During a \"late\" load instead of executing all top level forms +of the original files, only function definitions are +loaded (paying attention to have these effective only if the +bytecode definition was not changed in the meanwhile)." (comp-ensure-native-compiler) (unless (member load '(nil t late)) - (error "LOAD must be nil t or 'late")) + (error "LOAD must be nil, t or 'late")) (unless (listp paths) (setf paths (list paths))) (let (files) commit 050de01d948fa2c07d9e8fbd73c683fdb615ff32 Author: Stefan Kangas Date: Thu Nov 19 22:09:37 2020 +0100 Support native compilation of packages on install * lisp/emacs-lisp/package.el (package-unpack) (package--native-compile): Native compile packages on install, if the feature is available. (Bug#44676) (package-native-compile): New defcustom. diff --git a/etc/NEWS b/etc/NEWS index 7aa5488250..803185f066 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -838,6 +838,10 @@ key binding / u package-menu-filter-upgradable / / package-menu-filter-clear +*** Option to automatically native compile packages on installation. +Customize the user option `package-native-compile' to enable automatic +native compilation of packages on installation. + --- *** Column widths in 'list-packages' display can now be customized. See the new user options 'package-name-column-width', diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index a381ca01f3..9264a811ce 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -389,6 +389,12 @@ a sane initial value." :version "25.1" :type '(repeat symbol)) +(defcustom package-native-compile nil + "Non-nil means to native compile packages on installation." + :type '(boolean) + :risky t + :version "28.1") + (defcustom package-menu-async t "If non-nil, package-menu will use async operations when possible. Currently, only the refreshing of archive contents supports @@ -968,6 +974,8 @@ untar into a directory named DIR; otherwise, signal an error." ;; E.g. for multi-package installs, we should first install all packages ;; and then compile them. (package--compile new-desc) + (when package-native-compile + (package--native-compile-async new-desc)) ;; After compilation, load again any files loaded by ;; `activate-1', so that we use the byte-compiled definitions. (package--load-files-for-activation new-desc :reload))) @@ -1052,6 +1060,15 @@ This assumes that `pkg-desc' has already been activated with (load-path load-path)) (byte-recompile-directory (package-desc-dir pkg-desc) 0 t))) +(defun package--native-compile-async (pkg-desc) + "Native compile installed package PKG-DESC asynchronously. +This assumes that `pkg-desc' has already been activated with +`package-activate-1'." + (when (and (featurep 'nativecomp) + (native-comp-available-p)) + (let ((warning-minimum-level :error)) + (native-compile-async (package-desc-dir pkg-desc) t)))) + ;;;; Inferring package from current buffer (defun package-read-from-string (str) "Read a Lisp expression from STR. commit a79365acaff843a144eacc620bfe6992051f84d4 Author: Stefan Kangas Date: Thu Nov 19 22:10:20 2020 +0100 compile-async: Don't error out on deferred compilation after load * lisp/emacs-lisp/comp.el (native-compile-async): Update comp-files-queue when deferred compilation is requested. (Bug#44676) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 633ededebe..095bd63a10 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -3511,14 +3511,12 @@ LOAD can be nil t or 'late." (list "Path not a file nor directory" path))))) (dolist (file files) (if-let ((entry (cl-find file comp-files-queue :key #'car :test #'string=))) - ;; When no load is specified (plain async compilation) we - ;; consider valid the one previously queued, otherwise we - ;; check for coherence (bug#40602). - (cl-assert (or (null load) - (eq load (cdr entry))) - nil "Trying to queue %s with LOAD %s but this is already \ -queued with LOAD %" - file load (cdr entry)) + ;; Most likely the byte-compiler has requested a deferred + ;; compilation, so update `comp-files-queue' to reflect that. + (unless (or (null load) + (eq load (cdr entry))) + (cl-substitute (cons file load) (car entry) comp-files-queue + :key #'car :test #'string=)) ;; Make sure we are not already compiling `file' (bug#40838). (unless (or (gethash file comp-async-compilations) ;; Also exclude files from deferred compilation if commit cf436db285bd27dae35fecfa9038c9ce48953853 Author: Stefan Kangas Date: Fri Nov 20 20:34:32 2020 +0100 ; Fix trivial typos diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 5508a60c44..6d2bff103e 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -602,7 +602,7 @@ Each element is (INDEX . VALUE)") "To spill default qualities from the compiled file.") (defvar byte-native-for-bootstrap nil "Non nil while compiling for bootstrap." - ;; During boostrap we produce both the .eln and the .elc together. + ;; During bootstrap we produce both the .eln and the .elc together. ;; Because the make target is the later this has to be produced as ;; last to be resilient against build interruptions. ) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index cc5922c61c..633ededebe 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -118,7 +118,7 @@ compilation input." :type 'hook) (defcustom comp-async-env-modifier-form nil - "Form evaluated before compilation by each asyncronous compilation worker. + "Form evaluated before compilation by each asynchronous compilation worker. Usable to modify the compiler environment." :type 'list) @@ -352,7 +352,7 @@ Needed to replace immediate byte-compiled lambdas with the compiled reference.") :documentation "Standard data relocated in use by functions.") (d-impure (make-comp-data-container) :type comp-data-container :documentation "Relocated data that cannot be moved into pure space. -This is tipically for top-level forms other than defun.") +This is typically for top-level forms other than defun.") (d-ephemeral (make-comp-data-container) :type comp-data-container :documentation "Relocated data not necessary after load.") (with-late-load nil :type boolean @@ -389,7 +389,7 @@ To be used when ncall-conv is nil.")) :documentation "List of instructions.") (closed nil :type boolean :documentation "t if closed.") - ;; All the followings are for SSA and CGF analysis. + ;; All the following are for SSA and CGF analysis. ;; Keep in sync with `comp-clean-ssa'!! (in-edges () :type list :documentation "List of incoming edges.") @@ -461,7 +461,7 @@ CFG is mutated by a pass.") (blocks (make-hash-table) :type hash-table :documentation "Basic block name -> basic block.") (lap-block (make-hash-table :test #'equal) :type hash-table - :documentation "LAP lable -> LIMPLE basic block name.") + :documentation "LAP label -> LIMPLE basic block name.") (edges-h (make-hash-table) :type hash-table :documentation "Hash edge-num -> edge connecting basic two blocks.") (block-cnt-gen (funcall #'comp-gen-counter) :type function @@ -749,7 +749,7 @@ Assume allocation class 'd-default as default." comp-curr-allocation-class)))) -;;; Log rountines. +;;; Log routines. (defconst comp-limple-lock-keywords `((,(rx bol "(comment" (1+ not-newline)) . font-lock-comment-face) @@ -873,7 +873,7 @@ instruction." Add PREFIX in front of it. If FIRST is not nil, pick the first available name ignoring compilation context and potential name clashes." - ;; Unfortunatelly not all symbol names are valid as C function names... + ;; Unfortunately not all symbol names are valid as C function names... ;; Nassi's algorithm here: (let* ((orig-name (if (symbolp name) (symbol-name name) name)) (crypted (cl-loop with str = (make-string (* 2 (length orig-name)) 0) @@ -2008,7 +2008,7 @@ Return the corresponding rhs slot number." (defun comp-cond-rw (_) "Rewrite conditional branches adding appropriate 'assume' insns. This is introducing and placing 'assume' insns in use by fwprop -to propagate conditional branch test informations on target basic +to propagate conditional branch test information on target basic blocks." (maphash (lambda (_ f) (when (and (>= (comp-func-speed f) 1) @@ -2051,7 +2051,7 @@ blocks." f)))) (defun comp-pure-infer-func (f) - "If all funtions called by F are pure then F is pure too." + "If all functions called by F are pure then F is pure too." (when (and (cl-every (lambda (x) (or (comp-function-pure-p x) (eq x (comp-func-name f)))) @@ -2094,7 +2094,7 @@ blocks." mvar)) (defun comp-clean-ssa (f) - "Clean-up SSA for funtion F." + "Clean-up SSA for function F." (setf (comp-func-edges-h f) (make-hash-table)) (cl-loop for b being each hash-value of (comp-func-blocks f) @@ -2367,7 +2367,7 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non-nil." do (finalize-phi args b))))) (defun comp-ssa () - "Port all functions into mininal SSA form." + "Port all functions into minimal SSA form." (maphash (lambda (_ f) (let* ((comp-func f) (ssa-status (comp-func-ssa-status f))) @@ -3139,7 +3139,7 @@ Prepare every function for final compilation and drive the C back-end." x) -;; Primitive funciton advice machinery +;; Primitive function advice machinery (defun comp-trampoline-filename (subr-name) "Given SUBR-NAME return the filename containing the trampoline." @@ -3445,7 +3445,7 @@ load once finished compiling." ;;;###autoload (defun native-compile (function-or-file &optional output) "Compile FUNCTION-OR-FILE into native code. -This is the syncronous entry-point for the Emacs Lisp native +This is the synchronous entry-point for the Emacs Lisp native compiler. FUNCTION-OR-FILE is a function symbol, a form or the filename of an Emacs Lisp source file. diff --git a/src/comp.c b/src/comp.c index 292f0e7e70..6ddfad528b 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1517,7 +1517,7 @@ emit_XFIXNUM (gcc_jit_rvalue *obj) emit_comment ("XFIXNUM"); gcc_jit_rvalue *i = emit_coerce (comp.emacs_uint_type, emit_XLI (obj)); - /* FIXME: Implementation dependent (both RSHIFT are arithmetics). */ + /* FIXME: Implementation dependent (both RSHIFT are arithmetic). */ if (!USE_LSB_TAG) { @@ -3780,7 +3780,7 @@ define_maybe_gc_or_quit (void) /* 9 translates into checking for GC or quit every 512 calls to 'maybe_gc_quit'. This is the smallest value I could find with no performance impact running elisp-banechmarks and the same - used by the byte intepreter (see 'exec_byte_code'). */ + used by the byte interpreter (see 'exec_byte_code'). */ maybe_do_it_block, pass_block); @@ -4067,7 +4067,7 @@ If BASE-DIR is nil use the first entry in `comp-eln-load-path'. */) included in the hashing algorithm. As at any point in time no more then one file can exist with the - same filename, should be possibile to clean up all + same filename, should be possible to clean up all filename-path_hash-* except the most recent one (or the new one being recompiled). @@ -4617,7 +4617,7 @@ register_native_comp_unit (Lisp_Object comp_u) loaded the compiler and its dependencies. */ static Lisp_Object delayed_sources; -/* Queue an asyncronous compilation for the source file defining +/* Queue an asynchronous compilation for the source file defining FUNCTION_NAME and perform a late load. NOTE: ideally would be nice to move its call simply into Fload but @@ -4671,7 +4671,7 @@ maybe_defer_native_compilation (Lisp_Object function_name, } /* This is to have deferred compilaiton able to compile comp - dependecies breaking circularity. */ + dependencies breaking circularity. */ if (!NILP (Ffeaturep (Qcomp, Qnil))) { /* Comp already loaded. */ @@ -5297,7 +5297,7 @@ If a directory is non absolute is assumed to be relative to `invocation-directory'. The last directory of this list is assumed to be the system one. */); - /* Temporary value in use for boostrap. We can't do better as + /* Temporary value in use for bootstrap. We can't do better as `invocation-directory' is still unset, will be fixed up during dump reload. */ Vcomp_eln_load_path = Fcons (build_string ("../native-lisp/"), Qnil); diff --git a/src/comp.h b/src/comp.h index 077250ea86..f7d17f398c 100644 --- a/src/comp.h +++ b/src/comp.h @@ -42,7 +42,7 @@ struct Lisp_Native_Comp_Unit Lisp_Object lambda_gc_guard_h; /* Hash c_name -> d_reloc_imp index. */ Lisp_Object lambda_c_name_idx_h; - /* Hash doc-idx -> function documentaiton. */ + /* Hash doc-idx -> function documentation. */ Lisp_Object data_fdoc_v; /* Analogous to the constant vector but per compilation unit. */ Lisp_Object data_vec; diff --git a/src/pdumper.c b/src/pdumper.c index c253fc53c4..e0f8f5577e 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -326,7 +326,7 @@ dump_fingerprint (char const *label, /* To be used if some order in the relocation process has to be enforced. */ enum reloc_phase { - /* First to run. Place here every relocation with no dependecy. */ + /* First to run. Place every relocation with no dependency here. */ EARLY_RELOCS, /* Late and very late relocs are relocated at the very last after all hooks has been run. All lisp machinery is at disposal diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index bf3f57a85e..fffc72015b 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -393,7 +393,7 @@ https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-03/msg00914.html." (defvar comp-test-primitive-advice) (comp-deftest primitive-advice () - "Test effectiveness of primitve advicing." + "Test effectiveness of primitive advicing." (let (comp-test-primitive-advice (f (lambda (&rest args) (setq comp-test-primitive-advice args)))) @@ -406,7 +406,7 @@ https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-03/msg00914.html." (defvar comp-test-primitive-redefine-args) (comp-deftest primitive-redefine () - "Test effectiveness of primitve redefinition." + "Test effectiveness of primitive redefinition." (cl-letf ((comp-test-primitive-redefine-args nil) ((symbol-function #'-) (lambda (&rest args) commit a55415af7ea8ddc09dfda32ccb866c6556bb71c1 Author: Andrea Corallo Date: Fri Nov 20 00:59:00 2020 +0100 Add 'EMACSNATIVELOADPATH' env variable support (bug#44726) * lisp/startup.el (normal-top-level): Read 'EMACSNATIVELOADPATH' and add entries too `comp-eln-load-path'. * lisp/mail/emacsbug.el (report-emacs-bug): Dump also 'EMACSNATIVELOADPATH'. diff --git a/lisp/mail/emacsbug.el b/lisp/mail/emacsbug.el index d524b26f1b..4af8780d98 100644 --- a/lisp/mail/emacsbug.el +++ b/lisp/mail/emacsbug.el @@ -313,7 +313,7 @@ usually do not have translators for other languages.\n\n"))) (lambda (var) (let ((val (getenv var))) (if val (insert (format " value of $%s: %s\n" var val))))) - '("EMACSDATA" "EMACSDOC" "EMACSLOADPATH" "EMACSPATH" + '("EMACSDATA" "EMACSDOC" "EMACSLOADPATH" "EMACSNATIVELOADPATH" "EMACSPATH" "LC_ALL" "LC_COLLATE" "LC_CTYPE" "LC_MESSAGES" "LC_MONETARY" "LC_NUMERIC" "LC_TIME" "LANG" "XMODIFIERS")) (insert (format " locale-coding-system: %s\n" locale-coding-system)) diff --git a/lisp/startup.el b/lisp/startup.el index 89b1d59ce0..2beeaa195d 100644 --- a/lisp/startup.el +++ b/lisp/startup.el @@ -534,9 +534,13 @@ It is the default value of the variable `top-level'." (setq user-emacs-directory (startup--xdg-or-homedot startup--xdg-config-home-emacs nil)) - (when (boundp 'comp-eln-load-path) - (setq comp-eln-load-path (cons (concat user-emacs-directory "eln-cache/") - comp-eln-load-path))) + (when (featurep 'nativecomp) + (let ((path-env (getenv "EMACSNATIVELOADPATH"))) + (when path-env + (dolist (path (split-string path-env ":")) + (unless (string= "" path) + (push path comp-eln-load-path))))) + (push (concat user-emacs-directory "eln-cache/") comp-eln-load-path)) ;; Look in each dir in load-path for a subdirs.el file. If we ;; find one, load it, which will add the appropriate subdirs of ;; that dir into load-path. This needs to be done before setting commit 3ae309bd59c608b4262209e225b963a8f73450e6 Author: Andrea Corallo Date: Wed Nov 18 17:50:03 2020 +0100 * Fix eln file hasing for symlink paths (bug#44701) * src/comp.c (Fcomp_el_to_eln_filename): Call `file-truename' in place of `expand-file-name' when available. diff --git a/src/comp.c b/src/comp.c index 5b0f58b1a4..292f0e7e70 100644 --- a/src/comp.c +++ b/src/comp.c @@ -4037,7 +4037,15 @@ If BASE-DIR is nil use the first entry in `comp-eln-load-path'. */) { CHECK_STRING (filename); - filename = Fexpand_file_name (filename, Qnil); + /* Use `file-truename' or fall back to `expand-file-name' when the + first is not available (bug#44701). + + `file-truename' is not available only for a short phases of the + bootstrap before file.el is loaded, given we do not symlink + inside the build directory this should work. */ + filename = NILP (Ffboundp (intern_c_string ("file-truename"))) + ? Fexpand_file_name (filename, Qnil) + : CALL1I (file-truename, filename); if (NILP (Ffile_exists_p (filename))) xsignal1 (Qfile_missing, filename); commit 4c453196a1fbb55e887c24c546632d346147959b Author: Jonas Bernoulli Date: Wed Nov 18 18:13:31 2020 +0100 Revert "[WIP] Add and improve section headings" This reverts commit 007a5a677573ab628426a0605eb38f8e68fe1953. diff --git a/lisp/allout.el b/lisp/allout.el index 07049a05d7..b56071de59 100644 --- a/lisp/allout.el +++ b/lisp/allout.el @@ -2529,10 +2529,10 @@ We skip anomalous low-level topics, a la `allout-aberrant-container-p'." ;;;_ - Subtree Charting ;;;_ " These routines either produce or assess charts, which are -;; nested lists of the locations of topics within a subtree. -;; -;; Charts enable efficient subtree navigation by providing a reusable basis -;; for elaborate, compound assessment and adjustment of a subtree. +;;; nested lists of the locations of topics within a subtree. +;;; +;;; Charts enable efficient subtree navigation by providing a reusable basis +;;; for elaborate, compound assessment and adjustment of a subtree. ;;;_ > allout-chart-subtree (&optional levels visible orig-depth prev-depth) (defun allout-chart-subtree (&optional levels visible orig-depth prev-depth) @@ -6514,7 +6514,6 @@ If BEG is bigger than END we return 0." ;; - and closes the last topic (this local-variables section). ;;Local variables: ;;allout-layout: (0 : -1 -1 0) -;;outline-regexp: ";;\\([;*]+ [^\s\t\n]\\|;_[ *+=>]*\\|###autoload\\)\\|(" ;;End: ;;; allout.el ends here diff --git a/lisp/icomplete.el b/lisp/icomplete.el index f84ef78434..4e546807b7 100644 --- a/lisp/icomplete.el +++ b/lisp/icomplete.el @@ -237,8 +237,8 @@ Last entry becomes the first and can be selected with (push (car last) comps) (completion--cache-all-sorted-completions beg end comps)))) -;;;_* Helpers for `fido-mode' (or `ido-mode' emulation) - +;;; Helpers for `fido-mode' (or `ido-mode' emulation) +;;; (defun icomplete-fido-kill () "Kill line or current completion, like `ido-mode'. If killing to the end of line make sense, call `kill-line', @@ -782,7 +782,7 @@ matches exist." "}") (concat determ " [Matched]")))))) -;;;_* Iswitchb compatibility +;;; Iswitchb compatibility ;; We moved Iswitchb to `obsolete' in 24.4, but autoloads in files in ;; `obsolete' aren't obeyed (since that would encourage people to keep using @@ -798,10 +798,9 @@ matches exist." ;;;_* Provide (provide 'icomplete) -;;;_* Local emacs vars. +;;_* Local emacs vars. ;;Local variables: ;;allout-layout: (-2 :) -;;outline-regexp: ";;\\([;*]+ [^\s\t\n]\\|;_[ *+=>]*\\|###autoload\\)\\|(" ;;End: ;;; icomplete.el ends here diff --git a/lisp/net/eudc.el b/lisp/net/eudc.el index 226bf7e087..08cab4f047 100644 --- a/lisp/net/eudc.el +++ b/lisp/net/eudc.el @@ -1150,9 +1150,7 @@ queries the server for the existing fields and displays a corresponding form." (cons "Directory Servers" (easy-menu-create-menu "Directory Servers" (cdr (eudc-menu)))))) -;;}}} - -;;{{{ Load time initializations +;;; Load time initializations : ;; Load the options file (if (and (not noninteractive) @@ -1209,7 +1207,5 @@ This does nothing except loading eudc by autoload side-effect." ;;}}} (provide 'eudc) -;; Local Variables: -;; outline-regexp: ";;\\([;*]+ [^\s\t\n]\\|{{{\\|###autoload\\)\\|(" -;; End: + ;;; eudc.el ends here commit df17e102a07a2839cfabf6a90e9dd09a562300b0 Author: Jonas Bernoulli Date: Wed Nov 18 18:13:27 2020 +0100 Revert "[TODO] Remove noisy anti-noise feature" This reverts commit c36b4eed2d76f0e804d27d35dd6281f858639f94. diff --git a/lisp/emacs-lisp/warnings.el b/lisp/emacs-lisp/warnings.el index 6cd7022e12..f525ea433a 100644 --- a/lisp/emacs-lisp/warnings.el +++ b/lisp/emacs-lisp/warnings.el @@ -292,6 +292,17 @@ entirely by setting `warning-suppress-types' or (insert (format (nth 1 level-info) (format warning-type-format typename)) message) + ;; Don't output the buttons when doing batch compilation + ;; and similar. + (unless (or noninteractive (eq type 'bytecomp)) + (insert " ") + (insert-button "Disable showing" + 'type 'warning-suppress-warning + 'warning-type type) + (insert " ") + (insert-button "Disable logging" + 'type 'warning-suppress-log-warning + 'warning-type type)) (funcall newline) (when (and warning-fill-prefix (not (string-match "\n" message))) (let ((fill-prefix warning-fill-prefix) commit c36b4eed2d76f0e804d27d35dd6281f858639f94 Author: Jonas Bernoulli Date: Wed Nov 18 15:18:07 2020 +0100 [TODO] Remove noisy anti-noise feature diff --git a/lisp/emacs-lisp/warnings.el b/lisp/emacs-lisp/warnings.el index f525ea433a..6cd7022e12 100644 --- a/lisp/emacs-lisp/warnings.el +++ b/lisp/emacs-lisp/warnings.el @@ -292,17 +292,6 @@ entirely by setting `warning-suppress-types' or (insert (format (nth 1 level-info) (format warning-type-format typename)) message) - ;; Don't output the buttons when doing batch compilation - ;; and similar. - (unless (or noninteractive (eq type 'bytecomp)) - (insert " ") - (insert-button "Disable showing" - 'type 'warning-suppress-warning - 'warning-type type) - (insert " ") - (insert-button "Disable logging" - 'type 'warning-suppress-log-warning - 'warning-type type)) (funcall newline) (when (and warning-fill-prefix (not (string-match "\n" message))) (let ((fill-prefix warning-fill-prefix) commit 007a5a677573ab628426a0605eb38f8e68fe1953 Author: Jonas Bernoulli Date: Wed Nov 18 14:08:42 2020 +0100 [WIP] Add and improve section headings diff --git a/lisp/allout.el b/lisp/allout.el index b56071de59..07049a05d7 100644 --- a/lisp/allout.el +++ b/lisp/allout.el @@ -2529,10 +2529,10 @@ We skip anomalous low-level topics, a la `allout-aberrant-container-p'." ;;;_ - Subtree Charting ;;;_ " These routines either produce or assess charts, which are -;;; nested lists of the locations of topics within a subtree. -;;; -;;; Charts enable efficient subtree navigation by providing a reusable basis -;;; for elaborate, compound assessment and adjustment of a subtree. +;; nested lists of the locations of topics within a subtree. +;; +;; Charts enable efficient subtree navigation by providing a reusable basis +;; for elaborate, compound assessment and adjustment of a subtree. ;;;_ > allout-chart-subtree (&optional levels visible orig-depth prev-depth) (defun allout-chart-subtree (&optional levels visible orig-depth prev-depth) @@ -6514,6 +6514,7 @@ If BEG is bigger than END we return 0." ;; - and closes the last topic (this local-variables section). ;;Local variables: ;;allout-layout: (0 : -1 -1 0) +;;outline-regexp: ";;\\([;*]+ [^\s\t\n]\\|;_[ *+=>]*\\|###autoload\\)\\|(" ;;End: ;;; allout.el ends here diff --git a/lisp/icomplete.el b/lisp/icomplete.el index 4e546807b7..f84ef78434 100644 --- a/lisp/icomplete.el +++ b/lisp/icomplete.el @@ -237,8 +237,8 @@ Last entry becomes the first and can be selected with (push (car last) comps) (completion--cache-all-sorted-completions beg end comps)))) -;;; Helpers for `fido-mode' (or `ido-mode' emulation) -;;; +;;;_* Helpers for `fido-mode' (or `ido-mode' emulation) + (defun icomplete-fido-kill () "Kill line or current completion, like `ido-mode'. If killing to the end of line make sense, call `kill-line', @@ -782,7 +782,7 @@ matches exist." "}") (concat determ " [Matched]")))))) -;;; Iswitchb compatibility +;;;_* Iswitchb compatibility ;; We moved Iswitchb to `obsolete' in 24.4, but autoloads in files in ;; `obsolete' aren't obeyed (since that would encourage people to keep using @@ -798,9 +798,10 @@ matches exist." ;;;_* Provide (provide 'icomplete) -;;_* Local emacs vars. +;;;_* Local emacs vars. ;;Local variables: ;;allout-layout: (-2 :) +;;outline-regexp: ";;\\([;*]+ [^\s\t\n]\\|;_[ *+=>]*\\|###autoload\\)\\|(" ;;End: ;;; icomplete.el ends here diff --git a/lisp/net/eudc.el b/lisp/net/eudc.el index 08cab4f047..226bf7e087 100644 --- a/lisp/net/eudc.el +++ b/lisp/net/eudc.el @@ -1150,7 +1150,9 @@ queries the server for the existing fields and displays a corresponding form." (cons "Directory Servers" (easy-menu-create-menu "Directory Servers" (cdr (eudc-menu)))))) -;;; Load time initializations : +;;}}} + +;;{{{ Load time initializations ;; Load the options file (if (and (not noninteractive) @@ -1207,5 +1209,7 @@ This does nothing except loading eudc by autoload side-effect." ;;}}} (provide 'eudc) - +;; Local Variables: +;; outline-regexp: ";;\\([;*]+ [^\s\t\n]\\|{{{\\|###autoload\\)\\|(" +;; End: ;;; eudc.el ends here commit cee6401c130bea0de727392e344d6073eed3297e Author: Stefan Kangas Date: Mon Nov 16 03:50:10 2020 +0100 Various doc fixes for comp.el and comp.c * lisp/emacs-lisp/comp.el: Remove redundant :group args. (comp-async-cu-done-hook, comp-async-all-done-hook) (comp-async-env-modifier-form, comp-dry-run) (comp-ensure-native-compiler, comp-func-ret-typeset) (comp-func-ret-range, comp-limple-lock-keywords) (comp-make-curr-block): * src/comp.c (Fcomp_el_to_eln_filename, Fcomp__init_ctxt) (Fcomp_native_driver_options_effective_p) (Fcomp__compile_ctxt_to_file, Fcomp_libgccjit_version) (Fcomp__register_lambda, Fcomp__register_subr) (Fcomp__late_register_subr, Fnative_elisp_load, syms_of_comp): Doc fixes. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index c84c254e58..cc5922c61c 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -23,6 +23,7 @@ ;; along with GNU Emacs. If not, see . ;;; Commentary: + ;; This code is an attempt to make the pig fly. ;; Or, to put it another way to make a 911 out of a turbocharged VW Bug. @@ -73,27 +74,23 @@ This intended for debugging the compiler itself. - 1 final limple is logged. - 2 LAP and final limple and some pass info are logged. - 3 max verbosity." - :type 'number - :group 'comp) + :type 'number) (defcustom comp-always-compile nil "Unconditionally (re-)compile all files." - :type 'boolean - :group 'comp) + :type 'boolean) (defcustom comp-deferred-compilation-black-list '() "List of regexps to exclude files from deferred native compilation. Skip if any is matching." - :type 'list - :group 'comp) + :type 'list) (defcustom comp-bootstrap-black-list '() "List of regexps to exclude files from native compilation during bootstrap. Skip if any is matching." - :type 'list - :group 'comp) + :type 'list) (defcustom comp-never-optimize-functions '(;; The following two are mandatory for Emacs to be working @@ -101,39 +98,33 @@ Skip if any is matching." ;; REMOVE. macroexpand rename-buffer) "Primitive functions for which we do not perform trampoline optimization." - :type 'list - :group 'comp) + :type 'list) (defcustom comp-async-jobs-number 0 "Default number of processes used for async compilation. When zero use half of the CPUs or at least one." - :type 'number - :group 'comp) + :type 'number) +;; FIXME: This an abnormal hook, and should be renamed to something +;; like `comp-async-cu-done-function'. (defcustom comp-async-cu-done-hook nil - "This hook is run whenever an asyncronous native compilation -finishes compiling a single compilation unit. + "Hook run after asynchronously compiling a single compilation unit. The argument FILE passed to the function is the filename used as compilation input." - :type 'hook - :group 'comp) + :type 'hook) (defcustom comp-async-all-done-hook nil - "This hook is run whenever the asyncronous native compilation -finishes compiling all input files." - :type 'hook - :group 'comp) + "Hook run after asynchronously compiling all input files." + :type 'hook) (defcustom comp-async-env-modifier-form nil - "Form to be evaluated by each asyncronous compilation worker -before compilation. Usable to modify the compiler environment." - :type 'list - :group 'comp) + "Form evaluated before compilation by each asyncronous compilation worker. +Usable to modify the compiler environment." + :type 'list) (defcustom comp-async-report-warnings-errors t "Report warnings and errors from native asynchronous compilation." - :type 'boolean - :group 'comp) + :type 'boolean) (defcustom comp-native-driver-options nil "Options passed verbatim to the native compiler's backend driver. @@ -142,11 +133,10 @@ affecting the assembler and linker are likely to be useful. Passing these options is only available in libgccjit version 9 and above." - :type 'list - :group 'comp) + :type 'list) (defvar comp-dry-run nil - "When non-nil run everything but the C back-end.") + "If non-nil, run everything but the C back-end.") (defconst comp-valid-source-re (rx ".el" (? ".gz") eos) "Regexp to match filename of valid input source files.") @@ -594,7 +584,7 @@ In use by the backend." (defun comp-ensure-native-compiler () "Make sure Emacs has native compiler support and libgccjit is loadable. -Raise an error otherwise. +Signal an error otherwise. To be used by all entry points." (cond ((null (featurep 'nativecomp)) @@ -774,7 +764,7 @@ Assume allocation class 'd-default as default." (,(rx-to-string `(seq "(" (group-n 1 (or ,@(mapcar #'symbol-name comp-limple-ops))))) (1 font-lock-keyword-face))) - "Highlights used by comp-limple-mode.") + "Highlights used by `comp-limple-mode'.") (define-derived-mode comp-limple-mode fundamental-mode "LIMPLE" "Syntax-highlight LIMPLE IR." @@ -1260,8 +1250,7 @@ If DST-N is specified use it otherwise assume it to be the current slot." (defun comp-make-curr-block (block-name entry-sp &optional addr) "Create a basic block with BLOCK-NAME and set it as current block. ENTRY-SP is the sp value when entering. -The block is added to the current function. -The block is returned." +Add block to the current function and return it." (let ((bb (make--comp-block-lap addr entry-sp block-name))) (setf (comp-limplify-curr-block comp-pass) bb (comp-limplify-pc comp-pass) addr diff --git a/src/comp.c b/src/comp.c index e126fa1b4e..5b0f58b1a4 100644 --- a/src/comp.c +++ b/src/comp.c @@ -4031,7 +4031,7 @@ make_directory_wrapper_1 (Lisp_Object ignore) DEFUN ("comp-el-to-eln-filename", Fcomp_el_to_eln_filename, Scomp_el_to_eln_filename, 1, 2, 0, - doc: /* Given a source FILENAME return the corresponding .eln filename. + doc: /* Return the corresponding .eln filename for source FILENAME. If BASE-DIR is nil use the first entry in `comp-eln-load-path'. */) (Lisp_Object filename, Lisp_Object base_dir) { @@ -4173,7 +4173,8 @@ DEFUN ("comp--install-trampoline", Fcomp__install_trampoline, DEFUN ("comp--init-ctxt", Fcomp__init_ctxt, Scomp__init_ctxt, 0, 0, 0, - doc: /* Initialize the native compiler context. Return t on success. */) + doc: /* Initialize the native compiler context. +Return t on success. */) (void) { load_gccjit_if_necessary (true); @@ -4331,8 +4332,7 @@ DEFUN ("comp-native-driver-options-effective-p", Fcomp_native_driver_options_effective_p, Scomp_native_driver_options_effective_p, 0, 0, 0, - doc: /* Return t if `comp-native-driver-options' is - effective nil otherwise. */) + doc: /* Return t if `comp-native-driver-options' is effective. */) (void) { #if defined (LIBGCCJIT_HAVE_gcc_jit_context_add_driver_option) \ @@ -4378,7 +4378,7 @@ restore_sigmask (void) DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, Scomp__compile_ctxt_to_file, 1, 1, 0, - doc: /* Compile as native code the current context to file FILENAME. */) + doc: /* Compile the current context as native code to file FILENAME. */) (Lisp_Object filename) { load_gccjit_if_necessary (true); @@ -4491,8 +4491,10 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, DEFUN ("comp-libgccjit-version", Fcomp_libgccjit_version, Scomp_libgccjit_version, 0, 0, 0, - doc: /* Return the libgccjit version in use in the form -(MAJOR MINOR PATCHLEVEL) or nil if unknown (pre GCC10). */) + doc: /* Return libgccjit version in use. + +The return value has the form (MAJOR MINOR PATCHLEVEL) or nil if +unknown (before GCC version 10). */) (void) { #if defined (LIBGCCJIT_HAVE_gcc_jit_version) || defined (WINDOWSNT) @@ -4974,8 +4976,8 @@ make_subr (Lisp_Object symbol_name, Lisp_Object minarg, Lisp_Object maxarg, DEFUN ("comp--register-lambda", Fcomp__register_lambda, Scomp__register_lambda, 7, 7, 0, - doc: /* This gets called by top_level_run during load phase to register - anonymous lambdas. */) + doc: /* Register anonymous lambda. +This gets called by top_level_run during the load phase. */) (Lisp_Object reloc_idx, Lisp_Object minarg, Lisp_Object maxarg, Lisp_Object c_name, Lisp_Object doc_idx, Lisp_Object intspec, Lisp_Object comp_u) @@ -5002,8 +5004,8 @@ DEFUN ("comp--register-lambda", Fcomp__register_lambda, Scomp__register_lambda, DEFUN ("comp--register-subr", Fcomp__register_subr, Scomp__register_subr, 7, 7, 0, - doc: /* This gets called by top_level_run during load phase to register - each exported subr. */) + doc: /* Register exported subr. +This gets called by top_level_run during the load phase. */) (Lisp_Object name, Lisp_Object minarg, Lisp_Object maxarg, Lisp_Object c_name, Lisp_Object doc_idx, Lisp_Object intspec, Lisp_Object comp_u) @@ -5028,8 +5030,8 @@ DEFUN ("comp--register-subr", Fcomp__register_subr, Scomp__register_subr, DEFUN ("comp--late-register-subr", Fcomp__late_register_subr, Scomp__late_register_subr, 7, 7, 0, - doc: /* This gets called by late_top_level_run during load - phase to register each exported subr. */) + doc: /* Register exported subr. +This gets called by late_top_level_run during the load phase. */) (Lisp_Object name, Lisp_Object minarg, Lisp_Object maxarg, Lisp_Object c_name, Lisp_Object doc, Lisp_Object intspec, Lisp_Object comp_u) @@ -5056,8 +5058,7 @@ file_in_eln_sys_dir (Lisp_Object filename) /* Load related routines. */ DEFUN ("native-elisp-load", Fnative_elisp_load, Snative_elisp_load, 1, 2, 0, doc: /* Load native elisp code FILENAME. - LATE_LOAD has to be non-nil when loading for deferred - compilation. */) +LATE_LOAD has to be non-nil when loading for deferred compilation. */) (Lisp_Object filename, Lisp_Object late_load) { CHECK_STRING (filename); @@ -5102,8 +5103,7 @@ DEFUN ("native-elisp-load", Fnative_elisp_load, Snative_elisp_load, 1, 2, 0, DEFUN ("native-comp-available-p", Fnative_comp_available_p, Snative_comp_available_p, 0, 0, 0, - doc: /* Returns t if native compilation of Lisp files is available in -this instance of Emacs, nil otherwise. */) + doc: /* Return non-nil if native compilation support is built-in. */) (void) { #ifdef HAVE_NATIVE_COMP @@ -5120,11 +5120,10 @@ syms_of_comp (void) #ifdef HAVE_NATIVE_COMP /* Compiler control customizes. */ DEFVAR_BOOL ("comp-deferred-compilation", comp_deferred_compilation, - doc: /* If non-nil compile asyncronously all .elc files -being loaded. + doc: /* If non-nil compile loaded .elc files asynchronously. -Once compilation happened each function definition is updated to the -native compiled one. */); +After compilation, each function definition is updated to the native +compiled one. */); comp_deferred_compilation = true; DEFSYM (Qcomp_speed, "comp-speed"); @@ -5275,8 +5274,8 @@ native compiled one. */); Vcomp_native_version_dir = Qnil; DEFVAR_LISP ("comp-deferred-pending-h", Vcomp_deferred_pending_h, - doc: /* Hash table symbol-name -> function-value. For - internal use during */); + doc: /* Hash table symbol-name -> function-value. +For internal use. */); Vcomp_deferred_pending_h = CALLN (Fmake_hash_table, QCtest, Qeq); DEFVAR_LISP ("comp-eln-to-el-h", Vcomp_eln_to_el_h, @@ -5296,9 +5295,8 @@ The last directory of this list is assumed to be the system one. */); Vcomp_eln_load_path = Fcons (build_string ("../native-lisp/"), Qnil); DEFVAR_BOOL ("comp-enable-subr-trampolines", comp_enable_subr_trampolines, - doc: /* When non-nil enable trampoline synthesis - triggerd by `fset' making primitives - redefinable effectivelly. */); + doc: /* If non-nil, enable trampoline synthesis triggered by `fset'. +This makes primitives redefinable effectively. */); DEFVAR_LISP ("comp-installed-trampolines-h", Vcomp_installed_trampolines_h, doc: /* Hash table subr-name -> installed trampoline. commit 898f929215cf644c651abf789b564fcbc50ffbdd Author: Andrea Corallo Date: Sun Nov 15 23:31:00 2020 +0100 Fix nativecomp cond-rw pass * lisp/emacs-lisp/comp.el (comp-mvar-symbol-p): Improve it. (comp-cond-rw-func): Fix logic for multiple predecessor on target block. * test/src/comp-tests.el (comp-test-cond-rw-1): New test. * test/src/comp-test-funcs.el (comp-test-cond-rw-1-1-f) (comp-test-cond-rw-1-2-f): New functions. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 397b0fd70b..c84c254e58 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -571,9 +571,10 @@ Integer values are handled in the `range' slot.") (> high most-positive-fixnum)) t)))) -(defsubst comp-mvar-symbol-p (mvar) +(defun comp-mvar-symbol-p (mvar) "Return t if MVAR is certainly a symbol." - (equal (comp-mvar-typeset mvar) '(symbol))) + (or (equal (comp-mvar-typeset mvar) '(symbol)) + (cl-every #'symbolp (comp-mvar-valset mvar)))) (defsubst comp-mvar-cons-p (mvar) "Return t if MVAR is certainly a cons." @@ -1999,12 +2000,20 @@ Return the corresponding rhs slot number." ,(and (or 'eq 'eql '= 'equal) test-fn) ,op1 ,op2)) (comment ,_comment-str) (cond-jump ,cond ,(pred comp-mvar-p) ,bb-1 ,_bb-2)) - (when-let ((target-slot1 (comp-cond-rw-target-slot - (comp-mvar-slot op1) (car insns-seq) b))) - (comp-emit-assume target-slot1 op2 bb-1 test-fn)) - (when-let ((target-slot2 (comp-cond-rw-target-slot - (comp-mvar-slot op2) (car insns-seq) b))) - (comp-emit-assume target-slot2 op1 bb-1 test-fn)) + ;; FIXME We guard the target block against having more + ;; then one predecessor. The right fix will be to add a + ;; new dedicated basic block for the assumptions so we + ;; can proceed always. + (when (= (length (comp-block-in-edges + (gethash bb-1 + (comp-func-blocks comp-func)))) + 1) + (when-let ((target-slot1 (comp-cond-rw-target-slot + (comp-mvar-slot op1) (car insns-seq) b))) + (comp-emit-assume target-slot1 op2 bb-1 test-fn)) + (when-let ((target-slot2 (comp-cond-rw-target-slot + (comp-mvar-slot op2) (car insns-seq) b))) + (comp-emit-assume target-slot2 op1 bb-1 test-fn))) (cl-return-from in-the-basic-block)))))) (defun comp-cond-rw (_) diff --git a/test/src/comp-test-funcs.el b/test/src/comp-test-funcs.el index bcf9fcb0fd..207b6455f7 100644 --- a/test/src/comp-test-funcs.el +++ b/test/src/comp-test-funcs.el @@ -370,6 +370,16 @@ (copy-comp-mvar insn) insn))) +(defun comp-test-cond-rw-1-1-f ()) + +(defun comp-test-cond-rw-1-2-f () + (let ((it (comp-test-cond-rw-1-1-f)) + (key 't)) + (if (or (equal it key) + (eq key t)) + it + nil))) + ;;;;;;;;;;;;;;;;;;;; ;; Tromey's tests ;; diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index d377b08993..bf3f57a85e 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -449,6 +449,10 @@ https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-03/msg00914.html." '(1 2 3 (4 5 6)))) (should (null (comp-test-copy-insn-f nil)))) +(comp-deftest comp-test-cond-rw-1 () + "Check cond-rw does not break target blocks with multiple predecessor." + (should (null (comp-test-cond-rw-1-2-f)))) + ;;;;;;;;;;;;;;;;;;;;; ;; Tromey's tests. ;; commit 54f2e9c06d599b795af45ab872915887e7649ef2 Author: Andrea Corallo Date: Sun Nov 15 12:03:59 2020 +0100 * Improve `comp-fwprop-call' * lisp/emacs-lisp/comp.el (comp-function-call-maybe-fold): Document return value. (comp-fwprop-call): Simplify and improve. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index b8f19b5f58..397b0fd70b 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -723,22 +723,6 @@ Return the corresponding `comp-constraint' or `comp-constraint-f'." "Type-hint predicate for function name FUNC." (when (memq func comp-type-hints) t)) -(defun comp-func-ret-typeset (func) - "Return the typeset returned by function FUNC." - (if-let ((spec (gethash func comp-known-constraints-h))) - (comp-constraint-typeset (comp-constraint-f-ret spec)) - '(t))) - -(defun comp-func-ret-range (func) - "Return the range returned by function FUNC." - (when-let ((spec (gethash func comp-known-constraints-h))) - (comp-constraint-range (comp-constraint-f-ret spec)))) - -(defun comp-func-ret-valset (func) - "Return the valset returned by function FUNC." - (when-let ((spec (gethash func comp-known-constraints-h))) - (comp-constraint-valset (comp-constraint-f-ret spec)))) - (defun comp-func-unique-in-cu-p (func) "Return t if FUNC is known to be unique in the current compilation unit." (if (symbolp func) @@ -2604,7 +2588,8 @@ Forward propagate immediate involed in assignments." (cl-every #'comp-mvar-value-vld-p args))) (defun comp-function-call-maybe-fold (insn f args) - "Given INSN when F is pure if all ARGS are known remove the function call." + "Given INSN when F is pure if all ARGS are known remove the function call. +Return non-nil if the function is folded successfully." (cl-flet ((rewrite-insn-as-setimm (insn value) ;; See `comp-emit-setimm'. (comp-add-const-to-relocs value) @@ -2675,14 +2660,12 @@ Return LVAL." "Propagate on a call INSN into LVAL. F is the function being called with arguments ARGS. Fold the call in case." - (if-let ((range (comp-func-ret-range f))) - (setf (comp-mvar-range lval) range - (comp-mvar-typeset lval) nil) - (if-let ((valset (comp-func-ret-valset f))) - (setf (comp-mvar-valset lval) valset - (comp-mvar-typeset lval) nil) - (setf (comp-mvar-typeset lval) (comp-func-ret-typeset f)))) - (comp-function-call-maybe-fold insn f args)) + (unless (comp-function-call-maybe-fold insn f args) + (when-let ((constr (gethash f comp-known-constraints-h))) + (let ((constr (comp-constraint-f-ret constr))) + (setf (comp-mvar-range lval) (comp-constraint-range constr) + (comp-mvar-valset lval) (comp-constraint-valset constr) + (comp-mvar-typeset lval) (comp-constraint-typeset constr)))))) (defun comp-fwprop-insn (insn) "Propagate within INSN." commit 2f8d0fca888a42d0553b3880416780bb12f8167c Author: Andrea Corallo Date: Sat Nov 14 23:22:57 2020 +0100 * Add more type specifiers * lisp/emacs-lisp/comp.el (comp-known-type-specifiers): Add more pure functions. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index da144e4a24..b8f19b5f58 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -243,6 +243,35 @@ Useful to hook into pass checkers.") (string< (function ((or string symbol) (or string symbol)) boolean)) (string-lessp (function ((or string symbol) (or string symbol)) boolean)) (string-search (function (string string) (or integer null))) + (string-to-char (function (string) integer)) + (string-to-number (function (string &optional integer) number)) + (string-to-syntax (function (string) cons)) + (substring (function (string &optional integer integer) string)) + (sxhash (function (t) integer)) + (sxhash-equal (function (t) integer)) + (sxhash-eq (function (t) integer)) + (sxhash-eql (function (t) integer)) + (symbol-function (function (symbol) t)) + (symbol-name (function (symbol) string)) + (symbol-plist (function (symbol) list)) + (symbol-value (function (symbol) t)) + (string-make-unibyte (function (string) string)) + (string-make-multibyte (function (string) string)) + (string-as-multibyte (function (string) string)) + (string-as-unibyte (function (string) string)) + (string-to-multibyte (function (string) string)) + (tan (function (number) float)) + (time-convert (function (t &optional (or boolean integer)) cons)) + (truncate (function (number) integer)) + (unibyte-char-to-multibyte (function (fixnum) fixnum)) ;; byte is fixnum + (upcase (function ((or fixnum string)) (or fixnum string))) + (user-full-name (function (&optional integer) string)) + (user-login-name (function (&optional integer) (or string null))) + (user-original-login-name (function (&optional integer) (or string null))) + (custom-variable-p (function (symbol) boolean)) + (vconcat (function (&rest sequence) vector)) + ;; TODO all window-* :x + (zerop (function (number) boolean)) ;; Type hints (comp-hint-fixnum (function (t) fixnum)) (comp-hint-cons (function (t) cons))) commit 2a8bf2222dd5d786375c131aa13dd1ea6f0cf104 Merge: f702426780 ad29bc74ca Author: Andrea Corallo Date: Sat Nov 14 22:07:54 2020 +0100 Merge remote-tracking branch 'savannah/master' into dev commit f702426780475309bdd33ef896d28dd33484246b Author: Andrea Corallo Date: Sat Nov 14 17:38:05 2020 +0100 Add `comp-constraint-to-type-spec' and better handle boolean type spec * lisp/emacs-lisp/comp.el (comp-constraint-to-type-spec): New function splitting out code from comp-ret-type-spec + better handle boolean type specifier. (comp-ret-type-spec): Rework to leverage `comp-constraint-to-type-spec'. * test/src/comp-tests.el (comp-tests-type-spec-tests): Add a testcase. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index d75a054782..da144e4a24 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -639,6 +639,41 @@ Return the corresponding `comp-constraint' or `comp-constraint-f'." h) "Hash table function -> `comp-constraint'") +(defun comp-constraint-to-type-spec (mvar) + "Given MVAR return its type specifier." + (let ((valset (comp-mvar-valset mvar)) + (typeset (comp-mvar-typeset mvar)) + (range (comp-mvar-range mvar))) + + (when valset + (when (memq nil valset) + (if (memq t valset) + (progn + ;; t and nil are values, convert into `boolean'. + (push 'boolean typeset) + (setf valset (remove t (remove nil valset)))) + ;; Only nil is a value, convert it into a `null' type specifier. + (setf valset (remove nil valset)) + (push 'null typeset)))) + + ;; Form proper integer type specifiers. + (setf range (cl-loop for (l . h) in range + for low = (if (integerp l) l '*) + for high = (if (integerp h) h '*) + collect `(integer ,low , high)) + valset (cl-remove-duplicates valset)) + + ;; Form the final type specifier. + (let ((res (append typeset + (when valset + `((member ,@valset))) + range))) + (if (> (length res) 1) + `(or ,@res) + (if (memq (car-safe res) '(member integer)) + res + (car res)))))) + (defun comp-set-op-p (op) "Assignment predicate for OP." (when (memq op comp-limple-sets) t)) @@ -2934,34 +2969,9 @@ Set it into the `ret-type-specifier' slot." do (pcase insn (`(return ,mvar) (push `(,mvar . nil) res)))) - finally (cl-return res)))) - (res-valset (comp-mvar-valset res-mvar)) - (res-typeset (comp-mvar-typeset res-mvar)) - (res-range (comp-mvar-range res-mvar))) - ;; If nil is a value convert it into a `null' type specifier. - (when res-valset - (when (memq nil res-valset) - (setf res-valset (remove nil res-valset)) - (push 'null res-typeset))) - - ;; Form proper integer type specifiers. - (setf res-range (cl-loop for (l . h) in res-range - for low = (if (integerp l) l '*) - for high = (if (integerp h) h '*) - collect `(integer ,low , high)) - res-valset (cl-remove-duplicates res-valset)) - - ;; Form the final type specifier. - (let ((res (append res-typeset - (when res-valset - `((member ,@res-valset))) - res-range))) - (setf (comp-func-ret-type-specifier func) - (if (> (length res) 1) - `(or ,@res) - (if (memq (car-safe res) '(member integer)) - res - (car res))))))) + finally (cl-return res))))) + (setf (comp-func-ret-type-specifier func) + (comp-constraint-to-type-spec res-mvar)))) (defun comp-finalize-container (cont) "Finalize data container CONT." diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index a293a490d9..d377b08993 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -880,7 +880,11 @@ Return a list of results." (when x (setf y x)) y)) - t))) + t) + + ((defun comp-tests-ret-type-spec-f (x y) + (eq x y)) + boolean))) (comp-deftest ret-type-spec () "Some derived return type specifier tests." commit bcecdedcb7ee02a58383de396bf05fda88654a30 Author: Andrea Corallo Date: Sat Nov 14 16:45:50 2020 +0100 Handle correctly quoting in *Native-compile-Log* buffer * lisp/emacs-lisp/comp.el (comp-log): Add `quoted' parameter and pass it to `comp-log-to-buffer'. (comp-log-to-buffer): Add `quoted' parameter and leverage `prin1' or `princ' accordingly. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index ffd483108d..d75a054782 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -731,7 +731,7 @@ Assume allocation class 'd-default as default." "Syntax-highlight LIMPLE IR." (setf font-lock-defaults '(comp-limple-lock-keywords))) -(cl-defun comp-log (data &optional (level 1)) +(cl-defun comp-log (data &optional (level 1) quoted) "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, @@ -742,15 +742,16 @@ log with `comp-log-to-buffer'." (atom (message "%s" data)) (t (dolist (elem data) (message "%s" elem)))) - (comp-log-to-buffer data)))) + (comp-log-to-buffer data quoted)))) -(cl-defun comp-log-to-buffer (data) +(cl-defun comp-log-to-buffer (data &optional quoted) "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)))) + (let* ((print-f (if quoted #'prin1 #'princ)) + (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) @@ -762,9 +763,9 @@ log with `comp-log-to-buffer'." (save-excursion (goto-char (point-max)) (cl-typecase data - (atom (princ data log-buffer)) + (atom (funcall print-f data log-buffer)) (t (dolist (elem data) - (princ elem log-buffer) + (funcall print-f elem log-buffer) (insert "\n")))) (insert "\n")) (when (and at-end-p log-window) @@ -780,7 +781,7 @@ VERBOSITY is a number between 0 and 3." (cl-loop for block-name being each hash-keys of (comp-func-blocks func) using (hash-value bb) do (comp-log (concat "<" (symbol-name block-name) ">") verbosity) - (comp-log (comp-block-insns bb) verbosity)))) + (comp-log (comp-block-insns bb) verbosity t)))) (defun comp-log-edges (func) "Log edges in FUNC." @@ -913,7 +914,7 @@ clashes." (gethash (aref (comp-func-byte-func func) 1) byte-to-native-lambdas-h)))) (cl-assert lap) - (comp-log lap 2) + (comp-log lap 2 t) (let ((arg-list (aref (comp-func-byte-func func) 0))) (setf (comp-func-l-args func) (comp-decrypt-arg-list arg-list function-name) @@ -951,7 +952,7 @@ clashes." (gethash (aref byte-code 1) byte-to-native-lambdas-h)))) (cl-assert lap) - (comp-log lap 2) + (comp-log lap 2 t) (if (comp-func-l-p func) (setf (comp-func-l-args func) (comp-decrypt-arg-list (aref byte-code 0) byte-code)) @@ -1005,7 +1006,7 @@ clashes." (puthash 0 (comp-func-frame-size func) (comp-func-array-h func)) (comp-add-func-to-ctxt func) (comp-log (format "Function %s:\n" name) 1) - (comp-log lap 1)))) + (comp-log lap 1 t)))) (cl-defmethod comp-spill-lap-function ((filename string)) "Byte-compile FILENAME spilling data from the byte compiler." commit 22da28cf6643b6293aa0255eca5f398dad23516d Author: Andrea Corallo Date: Sat Nov 14 16:25:56 2020 +0100 * Split logic into comp-fwprop-call and improve it * lisp/emacs-lisp/comp.el (comp-func-ret-valset) (comp-fwprop-call): New functions. (comp-fwprop-insn): Remove code duplicaiton and call `comp-fwprop-call'. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index fa94d399eb..ffd483108d 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -670,6 +670,11 @@ Return the corresponding `comp-constraint' or `comp-constraint-f'." (when-let ((spec (gethash func comp-known-constraints-h))) (comp-constraint-range (comp-constraint-f-ret spec)))) +(defun comp-func-ret-valset (func) + "Return the valset returned by function FUNC." + (when-let ((spec (gethash func comp-known-constraints-h))) + (comp-constraint-valset (comp-constraint-f-ret spec)))) + (defun comp-func-unique-in-cu-p (func) "Return t if FUNC is known to be unique in the current compilation unit." (if (symbolp func) @@ -2601,26 +2606,29 @@ Return LVAL." (mapcar #'comp-mvar-range rhs-mvars)))) lval)) +(defun comp-fwprop-call (insn lval f args) + "Propagate on a call INSN into LVAL. +F is the function being called with arguments ARGS. +Fold the call in case." + (if-let ((range (comp-func-ret-range f))) + (setf (comp-mvar-range lval) range + (comp-mvar-typeset lval) nil) + (if-let ((valset (comp-func-ret-valset f))) + (setf (comp-mvar-valset lval) valset + (comp-mvar-typeset lval) nil) + (setf (comp-mvar-typeset lval) (comp-func-ret-typeset f)))) + (comp-function-call-maybe-fold insn f args)) + (defun comp-fwprop-insn (insn) "Propagate within INSN." (pcase insn (`(set ,lval ,rval) (pcase rval (`(,(or 'call 'callref) ,f . ,args) - (if-let ((range (comp-func-ret-range f))) - (setf (comp-mvar-range lval) range - (comp-mvar-typeset lval) nil) - (setf (comp-mvar-typeset lval) - (comp-func-ret-typeset f))) - (comp-function-call-maybe-fold insn f args)) + (comp-fwprop-call insn lval f args)) (`(,(or 'direct-call 'direct-callref) ,f . ,args) (let ((f (comp-func-name (gethash f (comp-ctxt-funcs-h comp-ctxt))))) - (if-let ((range (comp-func-ret-range f))) - (setf (comp-mvar-range lval) range - (comp-mvar-typeset lval) nil) - (setf (comp-mvar-typeset lval) - (comp-func-ret-typeset f))) - (comp-function-call-maybe-fold insn f args))) + (comp-fwprop-call insn lval f args))) (_ (comp-mvar-propagate lval rval)))) (`(assume ,lval ,rval ,kind) commit 3d14a74f8f35fe16823361beb03dd0957dd6f510 Author: Andrea Corallo Date: Sat Nov 14 11:24:30 2020 +0100 * Fix debug symbol emission * src/comp.c (Fcomp__compile_ctxt_to_file): Now that we do not rely anymore on globlal variables move logic in from 'Fcomp__init_ctxt' so comp.debug is already set correctly. diff --git a/src/comp.c b/src/comp.c index 0d46428185..e126fa1b4e 100644 --- a/src/comp.c +++ b/src/comp.c @@ -4215,26 +4215,6 @@ DEFUN ("comp--init-ctxt", Fcomp__init_ctxt, Scomp__init_ctxt, comp.ctxt = gcc_jit_context_acquire (); - if (comp.debug) - { - gcc_jit_context_set_bool_option (comp.ctxt, - GCC_JIT_BOOL_OPTION_DEBUGINFO, - 1); - } - if (comp.debug > 2) - { - logfile = fopen ("libgccjit.log", "w"); - gcc_jit_context_set_logfile (comp.ctxt, - logfile, - 0, 0); - gcc_jit_context_set_bool_option (comp.ctxt, - GCC_JIT_BOOL_OPTION_KEEP_INTERMEDIATES, - 1); - gcc_jit_context_set_bool_option (comp.ctxt, - GCC_JIT_BOOL_OPTION_DUMP_EVERYTHING, - 1); - } - comp.void_type = gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_VOID); comp.void_ptr_type = gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_VOID_PTR); @@ -4408,6 +4388,25 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, comp.speed = XFIXNUM (CALL1I (comp-ctxt-speed, Vcomp_ctxt)); comp.debug = XFIXNUM (CALL1I (comp-ctxt-debug, Vcomp_ctxt)); + + if (comp.debug) + gcc_jit_context_set_bool_option (comp.ctxt, + GCC_JIT_BOOL_OPTION_DEBUGINFO, + 1); + if (comp.debug > 2) + { + logfile = fopen ("libgccjit.log", "w"); + gcc_jit_context_set_logfile (comp.ctxt, + logfile, + 0, 0); + gcc_jit_context_set_bool_option (comp.ctxt, + GCC_JIT_BOOL_OPTION_KEEP_INTERMEDIATES, + 1); + gcc_jit_context_set_bool_option (comp.ctxt, + GCC_JIT_BOOL_OPTION_DUMP_EVERYTHING, + 1); + } + gcc_jit_context_set_int_option (comp.ctxt, GCC_JIT_INT_OPTION_OPTIMIZATION_LEVEL, comp.speed < 0 ? 0 commit aced2cf6ac50d3c62380c224c7d553f597c1f574 Author: Andrea Corallo Date: Sat Nov 14 16:55:39 2020 +0100 * Add a number of type specifiers for pure function * lisp/emacs-lisp/comp.el (comp-known-type-specifiers): Add 60 pure function type specifiers. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 96b2b29043..fa94d399eb 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -191,6 +191,7 @@ For internal use only by the testsuite.") Each function in FUNCTIONS is run after PASS. Useful to hook into pass checkers.") +;; FIXME this probably should not be here but... good for now. (defconst comp-known-type-specifiers `((cons (function (t t) cons)) (1+ (function ((or number marker)) number)) @@ -199,7 +200,52 @@ Useful to hook into pass checkers.") (- (function (&rest (or number marker)) number)) (* (function (&rest (or number marker)) number)) (/ (function ((or number marker) &rest (or number marker)) number)) - (% (function ((or number marker) (or number marker)) number))) + (% (function ((or number marker) (or number marker)) number)) + (concat (function (&rest sequence) string)) + (regexp-opt (function (list) string)) + (string-to-char (function (string) integer)) + (symbol-name (function (symbol) string)) + (eq (function (t t) boolean)) + (eql (function (t t) boolean)) + (= (function ((or number marker) (or number marker)) boolean)) + (/= (function ((or number marker) (or number marker)) boolean)) + (< (function ((or number marker) &rest (or number marker)) boolean)) + (<= (function ((or number marker) &rest (or number marker)) boolean)) + (>= (function ((or number marker) &rest (or number marker)) boolean)) + (> (function ((or number marker) &rest (or number marker)) boolean)) + (min (function ((or number marker) &rest (or number marker)) number)) + (max (function ((or number marker) &rest (or number marker)) number)) + (mod (function ((or number marker) (or number marker)) + (or (integer 0 *) (float 0 *)))) + (abs (function (number) number)) + (ash (function (integer integer) integer)) + (sqrt (function (number) float)) + (logand (function (&rest (or integer marker)) integer)) + (logior (function (&rest (or integer marker)) integer)) + (lognot (function (integer) integer)) + (logxor (function (&rest (or integer marker)) integer)) + (logcount (function (integer) integer)) + (copysign (function (float float) float)) + (isnan (function (float) boolean)) + (ldexp (function (number integer) float)) + (float (function (number) float)) + (logb (function (number) integer)) + (floor (function (number &optional number) integer)) + (ceiling (function (number &optional number) integer)) + (round (function (number &optional number) integer)) + (truncate (function (number &optional number) integer)) + (ffloor (function (float) float)) + (fceiling (function (float) float)) + (fround (function (float) float)) + (ftruncate (function (float) float)) + (string= (function ((or string symbol) (or string symbol)) boolean)) + (string-equal (function ((or string symbol) (or string symbol)) boolean)) + (string< (function ((or string symbol) (or string symbol)) boolean)) + (string-lessp (function ((or string symbol) (or string symbol)) boolean)) + (string-search (function (string string) (or integer null))) + ;; Type hints + (comp-hint-fixnum (function (t) fixnum)) + (comp-hint-cons (function (t) cons))) "Alist used for type propagation.") (defconst comp-symbol-values-optimizable '(most-positive-fixnum commit a467fa5c499c5808c6886d0d71640c1352498db8 Author: Andrea Corallo Date: Thu Nov 12 17:27:31 2020 +0100 Characterize functions in terms of type specifiers * lisp/emacs-lisp/comp.el (comp-known-type-specifiers): New const in place of `comp-known-ret-types' and `comp-known-ret-ranges'. (comp-constraint): New struct to separate the constraint side of an mvar. (comp-constraint-f): Analogous for functions. (comp-mvar): Rework and include `comp-constraint'. (comp-type-spec-to-constraint): New function. (comp-known-constraints-h): New const. (comp-func-ret-typeset, comp-func-ret-range): Rework. (comp-fwprop-insn): Fix. * test/src/comp-tests.el (destructure-type-spec): New testcase. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 217eec1b56..96b2b29043 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -191,31 +191,17 @@ For internal use only by the testsuite.") Each function in FUNCTIONS is run after PASS. Useful to hook into pass checkers.") -(defconst comp-known-ret-types '((cons . (cons)) - (1+ . (number)) - (1- . (number)) - (+ . (number)) - (- . (number)) - (* . (number)) - (/ . (number)) - (% . (number)) - ;; Type hints - (comp-hint-cons . (cons))) +(defconst comp-known-type-specifiers + `((cons (function (t t) cons)) + (1+ (function ((or number marker)) number)) + (1- (function ((or number marker)) number)) + (+ (function (&rest (or number marker)) number)) + (- (function (&rest (or number marker)) number)) + (* (function (&rest (or number marker)) number)) + (/ (function ((or number marker) &rest (or number marker)) number)) + (% (function ((or number marker) (or number marker)) number))) "Alist used for type propagation.") -(defconst comp-known-ret-ranges - `((comp-hint-fixnum . (,most-negative-fixnum . ,most-positive-fixnum))) - "Known returned ranges.") - -;; TODO fill it. -(defconst comp-type-predicates '((cons . consp) - (float . floatp) - (integer . integerp) - (number . numberp) - (string . stringp) - (symbol . symbolp)) - "Alist type -> predicate.") - (defconst comp-symbol-values-optimizable '(most-positive-fixnum most-negative-fixnum) "Symbol values we can resolve in the compile-time.") @@ -438,22 +424,33 @@ CFG is mutated by a pass.") (lambda-list nil :type list :documentation "Original lambda-list.")) -(cl-defstruct (comp-mvar (:constructor make--comp-mvar)) - "A meta-variable being a slot in the meta-stack." - (id nil :type (or null number) - :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.") +(cl-defstruct comp-constraint + "Internal representation of a type/value constraint." (typeset '(t) :type list :documentation "List of possible types the mvar can assume. Each element cannot be a subtype of any other element of this slot.") (valset '() :type list :documentation "List of possible values the mvar can assume. -Interg values are handled in the `range' slot.") +Integer values are handled in the `range' slot.") (range '() :type list :documentation "Integer interval.")) +(cl-defstruct comp-constraint-f + "Internal constraint representation for a function." + (args nil :type (or null list) + :documentation "List of `comp-constraint' for its arguments.") + (ret nil :type (or comp-constraint comp-constraint-f) + :documentation "Returned value `comp-constraint'.")) + +(cl-defstruct (comp-mvar (:constructor make--comp-mvar) + (:include comp-constraint)) + "A meta-variable being a slot in the meta-stack." + (id nil :type (or null number) + :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.")) + (defun comp-mvar-value-vld-p (mvar) "Return t if one single value can be extracted by the MVAR constrains." (when (null (comp-mvar-typeset mvar)) @@ -529,6 +526,73 @@ To be used by all entry points." ((null (native-comp-available-p)) (error "Cannot find libgccjit")))) +(cl-defun comp-type-spec-to-constraint (type-specifier) + "Destructure TYPE-SPECIFIER. +Return the corresponding `comp-constraint' or `comp-constraint-f'." + (let (typeset valset range) + (cl-labels ((star-or-num (x) + (or (numberp x) (eq '* x))) + (destructure-push (x) + (pcase x + ('&optional + (cl-return-from comp-type-spec-to-constraint '&optional)) + ('&rest + (cl-return-from comp-type-spec-to-constraint '&rest)) + ('null + (push nil valset)) + ('boolean + (push t valset) + (push nil valset)) + ('fixnum + (push `(,most-negative-fixnum . ,most-positive-fixnum) + range)) + ('bignum + (push `(- . ,(1- most-negative-fixnum)) + range) + (push `(,(1+ most-positive-fixnum) . +) + range)) + ((pred symbolp) + (push x typeset)) + (`(member . ,rest) + (setf valset (append rest valset))) + ('(integer * *) + (push '(- . +) range)) + (`(integer ,(and low (pred integerp)) *) + (push `(,low . +) range)) + (`(integer * ,(and high (pred integerp))) + (push `(- . ,high) range)) + (`(integer ,(and low (pred integerp)) + ,(and high (pred integerp))) + (push `(,low . ,high) range)) + (`(float ,(pred star-or-num) ,(pred star-or-num)) + ;; No float range support :/ + (push 'float typeset)) + (`(function ,args ,ret-type-spec) + (cl-return-from + comp-type-spec-to-constraint + (make-comp-constraint-f + :args (mapcar #'comp-type-spec-to-constraint args) + :ret (comp-type-spec-to-constraint ret-type-spec)))) + (_ (error "Unsopported type specifier"))))) + (if (or (atom type-specifier) + (memq (car type-specifier) '(member integer float function))) + (destructure-push type-specifier) + (if (eq (car type-specifier) 'or) + (mapc #'destructure-push (cdr type-specifier)) + (error "Unsopported type specifier"))) + (make-comp-constraint :typeset typeset + :valset valset + :range range)))) + +(defconst comp-known-constraints-h + (let ((h (make-hash-table :test #'eq))) + (cl-loop + for (f type-spec) in comp-known-type-specifiers + for constr = (comp-type-spec-to-constraint type-spec) + do (puthash f constr h)) + h) + "Hash table function -> `comp-constraint'") + (defun comp-set-op-p (op) "Assignment predicate for OP." (when (memq op comp-limple-sets) t)) @@ -550,12 +614,15 @@ To be used by all entry points." (when (memq func comp-type-hints) t)) (defun comp-func-ret-typeset (func) - "Return the typeset returned by function FUNC. " - (or (alist-get func comp-known-ret-types) '(t))) + "Return the typeset returned by function FUNC." + (if-let ((spec (gethash func comp-known-constraints-h))) + (comp-constraint-typeset (comp-constraint-f-ret spec)) + '(t))) -(defsubst comp-func-ret-range (func) - "Return the range returned by function FUNC. " - (alist-get func comp-known-ret-ranges)) +(defun comp-func-ret-range (func) + "Return the range returned by function FUNC." + (when-let ((spec (gethash func comp-known-constraints-h))) + (comp-constraint-range (comp-constraint-f-ret spec)))) (defun comp-func-unique-in-cu-p (func) "Return t if FUNC is known to be unique in the current compilation unit." @@ -2495,7 +2562,7 @@ Return LVAL." (pcase rval (`(,(or 'call 'callref) ,f . ,args) (if-let ((range (comp-func-ret-range f))) - (setf (comp-mvar-range lval) (list range) + (setf (comp-mvar-range lval) range (comp-mvar-typeset lval) nil) (setf (comp-mvar-typeset lval) (comp-func-ret-typeset f))) @@ -2503,7 +2570,7 @@ Return LVAL." (`(,(or 'direct-call 'direct-callref) ,f . ,args) (let ((f (comp-func-name (gethash f (comp-ctxt-funcs-h comp-ctxt))))) (if-let ((range (comp-func-ret-range f))) - (setf (comp-mvar-range lval) (list range) + (setf (comp-mvar-range lval) range (comp-mvar-typeset lval) nil) (setf (comp-mvar-typeset lval) (comp-func-ret-typeset f))) diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index b2f8399883..a293a490d9 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -1000,4 +1000,39 @@ Return a list of results." (should (equal (comp-union-typesets '(integer symbol) '()) '(symbol integer))))) +(comp-deftest destructure-type-spec () + (should (equal (comp-type-spec-to-constraint 'symbol) + (make-comp-constraint :typeset '(symbol)))) + (should (equal (comp-type-spec-to-constraint '(or symbol number)) + (make-comp-constraint :typeset '(number symbol)))) + (should-error (comp-type-spec-to-constraint '(symbol number))) + (should (equal (comp-type-spec-to-constraint '(member foo bar)) + (make-comp-constraint :typeset nil :valset '(foo bar)))) + (should (equal (comp-type-spec-to-constraint '(integer 1 2)) + (make-comp-constraint :typeset nil :range '((1 . 2))))) + (should (equal (comp-type-spec-to-constraint '(or (integer 1 2) (integer 4 5))) + (make-comp-constraint :typeset nil :range '((4 . 5) (1 . 2))))) + (should (equal (comp-type-spec-to-constraint '(integer * 2)) + (make-comp-constraint :typeset nil :range '((- . 2))))) + (should (equal (comp-type-spec-to-constraint '(integer 1 *)) + (make-comp-constraint :typeset nil :range '((1 . +))))) + (should (equal (comp-type-spec-to-constraint '(integer * *)) + (make-comp-constraint :typeset nil :range '((- . +))))) + (should (equal (comp-type-spec-to-constraint '(or (integer 1 2) + (member foo bar))) + (make-comp-constraint :typeset nil + :valset '(foo bar) + :range '((1 . 2))))) + (should (equal (comp-type-spec-to-constraint + '(function (t t) cons)) + (make-comp-constraint-f + :args `(,(make-comp-constraint :typeset '(t)) + ,(make-comp-constraint :typeset '(t))) + :ret (make-comp-constraint :typeset '(cons))))) + (should (equal (comp-type-spec-to-constraint + '(function ((or integer symbol)) float)) + (make-comp-constraint-f + :args `(,(make-comp-constraint :typeset '(symbol integer))) + :ret (make-comp-constraint :typeset '(float)))))) + ;;; comp-tests.el ends here commit 9bb2fc1e647bb74fd37a62c0b2f35c8eb4f8eece Author: Andrea Corallo Date: Thu Nov 12 23:41:04 2020 +0100 Add copy insn testcase * test/src/comp-tests.el (copy-insn): New testcase. * test/src/comp-test-funcs.el (comp-test-copy-insn-f): New function. diff --git a/test/src/comp-test-funcs.el b/test/src/comp-test-funcs.el index 1b0f3056b9..bcf9fcb0fd 100644 --- a/test/src/comp-test-funcs.el +++ b/test/src/comp-test-funcs.el @@ -354,6 +354,22 @@ comp-test-and-3-var 2)) +(defun comp-test-copy-insn-f (insn) + ;; From `comp-copy-insn'. + (if (consp insn) + (let (result) + (while (consp insn) + (let ((newcar (car insn))) + (if (or (consp (car insn)) (comp-mvar-p (car insn))) + (setf newcar (comp-copy-insn (car insn)))) + (push newcar result)) + (setf insn (cdr insn))) + (nconc (nreverse result) + (if (comp-mvar-p insn) (comp-copy-insn insn) insn))) + (if (comp-mvar-p insn) + (copy-comp-mvar insn) + insn))) + ;;;;;;;;;;;;;;;;;;;; ;; Tromey's tests ;; diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 61838c670e..b2f8399883 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -444,6 +444,11 @@ https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-03/msg00914.html." (should (= (comp-test-and-3-f t) 2)) (should (null (comp-test-and-3-f '(1 2))))) +(comp-deftest copy-insn () + (should (equal (comp-test-copy-insn-f '(1 2 3 (4 5 6))) + '(1 2 3 (4 5 6)))) + (should (null (comp-test-copy-insn-f nil)))) + ;;;;;;;;;;;;;;;;;;;;; ;; Tromey's tests. ;; commit c412d396b0e714c604b3386369b64f0c7e762fe8 Author: Andrea Corallo Date: Thu Nov 12 23:38:01 2020 +0100 * lisp/emacs-lisp/comp.el (comp-mvar-value-vld-p): Fix logic. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 583a3364df..217eec1b56 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -456,15 +456,21 @@ Interg values are handled in the `range' slot.") (defun comp-mvar-value-vld-p (mvar) "Return t if one single value can be extracted by the MVAR constrains." - (or (= (length (comp-mvar-valset mvar)) 1) - (let ((r (comp-mvar-range mvar))) - (and (= (length r) 1) - (let ((low (caar r)) - (high (cdar r))) - (and - (integerp low) - (integerp high) - (= low high))))))) + (when (null (comp-mvar-typeset mvar)) + (let* ((v (comp-mvar-valset mvar)) + (r (comp-mvar-range mvar)) + (valset-len (length v)) + (range-len (length r))) + (if (and (= valset-len 1) + (= range-len 0)) + t + (when (and (= valset-len 0) + (= range-len 1)) + (let* ((low (caar r)) + (high (cdar r))) + (and (integerp low) + (integerp high) + (= low high)))))))) (defun comp-mvar-value (mvar) "Return the constant value of MVAR. commit a37cc95e21675e4f8865a9c20c8acfc158a9827a Author: Andrea Corallo Date: Thu Nov 12 21:59:59 2020 +0100 * Memoize `comp-common-supertype' * lisp/emacs-lisp/comp.el (comp-ctxt): Add `common-supertype-mem' slot. (comp-common-supertype): Memoize. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 5965491397..583a3364df 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -308,7 +308,10 @@ This is tipically for top-level forms other than defun.") :documentation "When non-nil support late load.") (union-typesets-mem (make-hash-table :test #'equal) :type hash-table :documentation "Serve memoization for -`comp-union-typesets'.")) +`comp-union-typesets'.") + (common-supertype-mem (make-hash-table :test #'equal) :type hash-table + :documentation "Serve memoization for +`comp-common-supertype'.")) (cl-defstruct comp-args-base (min nil :type number @@ -2252,7 +2255,10 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non-nil." (defun comp-common-supertype (&rest types) "Return the first common supertype of TYPES." - (cl-reduce #'comp-common-supertype-2 types)) + (or (gethash types (comp-ctxt-common-supertype-mem comp-ctxt)) + (puthash types + (cl-reduce #'comp-common-supertype-2 types) + (comp-ctxt-common-supertype-mem comp-ctxt)))) (defsubst comp-subtype-p (type1 type2) "Return t if TYPE1 is a subtype of TYPE1 or nil otherwise." commit c3daee78004b8bfc3459b0f763540bdf01cc96f8 Author: Andrea Corallo Date: Thu Nov 12 15:11:58 2020 +0100 * Add few more type specifier tests * test/src/comp-tests.el (comp-tests-type-spec-tests): Add three tests and uncomment one. diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 23c4df8820..61838c670e 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -771,19 +771,19 @@ Return a list of results." (native-compile (cadr func-form)))) (defconst comp-tests-type-spec-tests - `(((defun comp-tests-ret-type-spec-0-f (x) + `(((defun comp-tests-ret-type-spec-f (x) x) - (t)) + t) - ((defun comp-tests-ret-type-spec-1-f () + ((defun comp-tests-ret-type-spec-f () 1) (integer 1 1)) - ((defun comp-tests-ret-type-spec-2-f (x) + ((defun comp-tests-ret-type-spec-f (x) (if x 1 3)) (or (integer 1 1) (integer 3 3))) - ((defun comp-tests-ret-type-spec-3-f (x) + ((defun comp-tests-ret-type-spec-f (x) (let (y) (if x (setf y 1) @@ -791,7 +791,7 @@ Return a list of results." y)) (integer 1 2)) - ((defun comp-tests-ret-type-spec-4-f (x) + ((defun comp-tests-ret-type-spec-f (x) (let (y) (if x (setf y 1) @@ -799,48 +799,48 @@ Return a list of results." y)) (or (integer 1 1) (integer 3 3))) - ((defun comp-tests-ret-type-spec-5-f (x) + ((defun comp-tests-ret-type-spec-f (x) (if x (list x) 3)) (or cons (integer 3 3))) - ((defun comp-tests-ret-type-spec-6-f (x) + ((defun comp-tests-ret-type-spec-f (x) (if x 'foo 3)) (or (member foo) (integer 3 3))) - ((defun comp-tests-ret-type-spec-7-1-f (x) + ((defun comp-tests-ret-type-spec-f (x) (if (eq x 3) x 'foo)) (or (member foo) (integer 3 3))) - ((defun comp-tests-ret-type-spec-7-2-f (x) + ((defun comp-tests-ret-type-spec-f (x) (if (eq 3 x) x 'foo)) (or (member foo) (integer 3 3))) - ((defun comp-tests-ret-type-spec-8-1-f (x) + ((defun comp-tests-ret-type-spec-f (x) (if (= x 3) x 'foo)) (or (member foo) (integer 3 3))) - ((defun comp-tests-ret-type-spec-8-2-f (x) + ((defun comp-tests-ret-type-spec-f (x) (if (= 3 x) x 'foo)) (or (member foo) (integer 3 3))) - ;; FIXME returning ATM (or t (member foo)) - ;; ((defun comp-tests-ret-type-spec-8-3-f (x) - ;; (if (= x 3) - ;; 'foo - ;; x)) - ;; (or number (member foo))) + ;; FIXME would be nice to have (or number (member foo)) + ((defun comp-tests-ret-type-spec-8-3-f (x) + (if (= x 3) + 'foo + x)) + t) ((defun comp-tests-ret-type-spec-8-4-f (x y) (if (= x y) @@ -852,9 +852,30 @@ Return a list of results." (comp-hint-fixnum y)) (integer ,most-negative-fixnum ,most-positive-fixnum)) - ((defun comp-tests-ret-type-spec-9-1-f (x) + ((defun comp-tests-ret-type-spec-f (x) (comp-hint-cons x)) - (cons)))) + cons) + + ((defun comp-tests-ret-type-spec-f (x) + (let (y) + (when x + (setf y 4)) + y)) + (or null (integer 4 4))) + + ((defun comp-tests-ret-type-spec-f () + (let (x + (y 3)) + (setf x y) + y)) + (integer 3 3)) + + ((defun comp-tests-ret-type-spec-f (x) + (let ((y 3)) + (when x + (setf y x)) + y)) + t))) (comp-deftest ret-type-spec () "Some derived return type specifier tests." commit 6f10e0f09fc3adc9a7a114100cd2864a4bd7c708 Author: Andrea Corallo Date: Thu Nov 12 15:08:58 2020 +0100 * Rework `comp-ret-type-spec' in terms of `comp-phi' * lisp/emacs-lisp/comp.el (comp-ret-type-spec): Use `comp-func' not to duplicate logic plus add null type specifier support and some comments. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 2c871ee7fc..5965491397 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2786,49 +2786,48 @@ These are substituted with a normal 'set' op." (defun comp-ret-type-spec (_ func) "Compute type specifier for `comp-func' FUNC. Set it into the `ret-type-specifier' slot." - (cl-loop - with res-typeset = nil - with res-valset = nil - with res-range = nil - for bb being the hash-value in (comp-func-blocks func) - do (cl-loop - for insn in (comp-block-insns bb) - do (pcase insn - (`(return ,mvar) - (when-let ((typeset (comp-mvar-typeset mvar))) - (setf res-typeset (comp-union-typesets res-typeset typeset))) - (when-let ((valset (comp-mvar-valset mvar))) - (setf res-valset (append res-valset valset))) - (when-let (range (comp-mvar-range mvar)) - (setf res-range (comp-range-union res-range range)))))) - finally - (when res-valset - (setf res-typeset - (cl-loop - with res = (copy-sequence res-typeset) - for type in res-typeset - for pred = (alist-get type comp-type-predicates) - when pred - do (cl-loop - for v in res-valset - when (funcall pred v) - do (setf res (remove type res))) - finally (cl-return res)))) - (setf res-range (cl-loop for (l . h) in res-range - for low = (if (numberp l) l '*) - for high = (if (numberp h) h '*) - collect `(integer ,low , high)) - res-valset (cl-remove-duplicates res-valset)) - (let ((res (append res-typeset - (when res-valset - `((member ,@res-valset))) - res-range))) - (setf (comp-func-ret-type-specifier func) - (if (> (length res) 1) - `(or ,@res) - (if (consp (car res)) - (car res) - res)))))) + (let* ((comp-func (make-comp-func)) + (res-mvar (apply #'comp-phi + (make-comp-mvar) + (cl-loop + with res = nil + for bb being the hash-value in (comp-func-blocks + func) + do (cl-loop + for insn in (comp-block-insns bb) + ;; Collect over every exit point the returned + ;; mvars and union results. + do (pcase insn + (`(return ,mvar) + (push `(,mvar . nil) res)))) + finally (cl-return res)))) + (res-valset (comp-mvar-valset res-mvar)) + (res-typeset (comp-mvar-typeset res-mvar)) + (res-range (comp-mvar-range res-mvar))) + ;; If nil is a value convert it into a `null' type specifier. + (when res-valset + (when (memq nil res-valset) + (setf res-valset (remove nil res-valset)) + (push 'null res-typeset))) + + ;; Form proper integer type specifiers. + (setf res-range (cl-loop for (l . h) in res-range + for low = (if (integerp l) l '*) + for high = (if (integerp h) h '*) + collect `(integer ,low , high)) + res-valset (cl-remove-duplicates res-valset)) + + ;; Form the final type specifier. + (let ((res (append res-typeset + (when res-valset + `((member ,@res-valset))) + res-range))) + (setf (comp-func-ret-type-specifier func) + (if (> (length res) 1) + `(or ,@res) + (if (memq (car-safe res) '(member integer)) + res + (car res))))))) (defun comp-finalize-container (cont) "Finalize data container CONT." commit c4749cebeb68d75456d5ea9188323276f26d5b43 Author: Andrea Corallo Date: Thu Nov 12 15:08:44 2020 +0100 * Move phi function code into dedicated function and improve it * lisp/emacs-lisp/comp.el (comp-phi): New function moving logic from `comp-fwprop-insn'. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index c863c29991..2c871ee7fc 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2437,6 +2437,45 @@ Forward propagate immediate involed in assignments." (value (comp-apply-in-env f (mapcar #'comp-mvar-value args)))) (rewrite-insn-as-setimm insn value))))))) +(defun comp-phi (lval &rest rvals) + "Phi function propagating RVALS into LVAL. +Return LVAL." + (let* ((rhs-mvars (mapcar #'car rvals)) + (values (mapcar #'comp-mvar-valset rhs-mvars)) + (from-latch (cl-some + (lambda (x) + (comp-latch-p + (gethash (cdr x) + (comp-func-blocks comp-func)))) + rvals))) + + ;; Type propagation. + (setf (comp-mvar-typeset lval) + (apply #'comp-union-typesets (mapcar #'comp-mvar-typeset rhs-mvars))) + + ;; Value propagation. + (setf (comp-mvar-valset lval) + (cl-loop + for v in (cl-remove-duplicates (apply #'append values) + :test #'equal) + ;; We propagate only values those types are not already + ;; into typeset. + when (cl-notany (lambda (x) + (comp-subtype-p (type-of v) x)) + (comp-mvar-typeset lval)) + collect v)) + + ;; Range propagation + (setf (comp-mvar-range lval) + (when (and (not from-latch) + (cl-notany (lambda (x) + (comp-subtype-p 'integer x)) + (comp-mvar-typeset lval))) + ;; TODO memoize? + (apply #'comp-range-union + (mapcar #'comp-mvar-range rhs-mvars)))) + lval)) + (defun comp-fwprop-insn (insn) "Propagate within INSN." (pcase insn @@ -2477,33 +2516,7 @@ Forward propagate immediate involed in assignments." (`(setimm ,lval ,v) (setf (comp-mvar-value lval) v)) (`(phi ,lval . ,rest) - (let* ((rvals (mapcar #'car rest)) - (values (mapcar #'comp-mvar-valset rvals)) - (from-latch (cl-some - (lambda (x) - (comp-latch-p - (gethash (cdr x) - (comp-func-blocks comp-func)))) - rest))) - - ;; Type propagation. - (setf (comp-mvar-typeset lval) - (apply #'comp-union-typesets (mapcar #'comp-mvar-typeset rvals))) - ;; Value propagation. - (setf (comp-mvar-valset lval) - (when (cl-every #'consp values) - ;; TODO memoize? - (cl-remove-duplicates (apply #'append values) - :test #'equal))) - ;; Range propagation - (setf (comp-mvar-range lval) - (when (and (not from-latch) - (cl-notany (lambda (x) - (comp-subtype-p 'integer x)) - (comp-mvar-typeset lval))) - ;; TODO memoize? - (apply #'comp-range-union - (mapcar #'comp-mvar-range rvals)))))))) + (apply #'comp-phi lval rest)))) (defun comp-fwprop* () "Propagate for set* and phi operands. commit 2435c103a4da85ae8b6bc48f3f964014d1cb6341 Author: Andrea Corallo Date: Wed Nov 11 17:59:46 2020 +0100 * Nativecomp testsuite rework for derived return type specifiers As we have derived return type specifiers as some test for them. Also rewrite some propagation related test using return type specifiers too as it's way more convenient. * test/src/comp-tests.el (fw-prop-1): Nit rename. (comp-tests-check-ret-type-spec): New function. (comp-tests-type-spec-tests): New variable. (comp-tests-cond-rw-0-var) Remove variable. (cond-rw-0, cond-rw-1, cond-rw-2, cond-rw-3, cond-rw-4, cond-rw-5) Remove tests as now covered by `comp-tests-check-ret-type-spec'. diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 8bedad5db7..23c4df8820 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -743,7 +743,7 @@ Return a list of results." (or (comp-tests-mentioned-p 'concat insn) (comp-tests-mentioned-p 'length insn))))))) -(comp-deftest fw-prop () +(comp-deftest fw-prop-1 () "Some tests for forward propagation." (let ((comp-speed 2) (comp-post-pass-hooks '((comp-final comp-tests-fw-prop-checker-1)))) @@ -757,6 +757,110 @@ Return a list of results." (should (subr-native-elisp-p (symbol-function #'comp-tests-fw-prop-1-f))) (should (= (comp-tests-fw-prop-1-f) 6)))) +(defun comp-tests-check-ret-type-spec (func-form type-specifier) + (let ((lexical-binding t) + (speed 2) + (comp-post-pass-hooks + `((comp-final + ,(lambda (_) + (let ((f (gethash (comp-c-func-name (cadr func-form) "F" t) + (comp-ctxt-funcs-h comp-ctxt)))) + (should (equal (comp-func-ret-type-specifier f) + type-specifier)))))))) + (eval func-form t) + (native-compile (cadr func-form)))) + +(defconst comp-tests-type-spec-tests + `(((defun comp-tests-ret-type-spec-0-f (x) + x) + (t)) + + ((defun comp-tests-ret-type-spec-1-f () + 1) + (integer 1 1)) + + ((defun comp-tests-ret-type-spec-2-f (x) + (if x 1 3)) + (or (integer 1 1) (integer 3 3))) + + ((defun comp-tests-ret-type-spec-3-f (x) + (let (y) + (if x + (setf y 1) + (setf y 2)) + y)) + (integer 1 2)) + + ((defun comp-tests-ret-type-spec-4-f (x) + (let (y) + (if x + (setf y 1) + (setf y 3)) + y)) + (or (integer 1 1) (integer 3 3))) + + ((defun comp-tests-ret-type-spec-5-f (x) + (if x + (list x) + 3)) + (or cons (integer 3 3))) + + ((defun comp-tests-ret-type-spec-6-f (x) + (if x + 'foo + 3)) + (or (member foo) (integer 3 3))) + + ((defun comp-tests-ret-type-spec-7-1-f (x) + (if (eq x 3) + x + 'foo)) + (or (member foo) (integer 3 3))) + + ((defun comp-tests-ret-type-spec-7-2-f (x) + (if (eq 3 x) + x + 'foo)) + (or (member foo) (integer 3 3))) + + ((defun comp-tests-ret-type-spec-8-1-f (x) + (if (= x 3) + x + 'foo)) + (or (member foo) (integer 3 3))) + + ((defun comp-tests-ret-type-spec-8-2-f (x) + (if (= 3 x) + x + 'foo)) + (or (member foo) (integer 3 3))) + + ;; FIXME returning ATM (or t (member foo)) + ;; ((defun comp-tests-ret-type-spec-8-3-f (x) + ;; (if (= x 3) + ;; 'foo + ;; x)) + ;; (or number (member foo))) + + ((defun comp-tests-ret-type-spec-8-4-f (x y) + (if (= x y) + x + 'foo)) + (or number (member foo))) + + ((defun comp-tests-ret-type-spec-9-1-f (x) + (comp-hint-fixnum y)) + (integer ,most-negative-fixnum ,most-positive-fixnum)) + + ((defun comp-tests-ret-type-spec-9-1-f (x) + (comp-hint-cons x)) + (cons)))) + +(comp-deftest ret-type-spec () + "Some derived return type specifier tests." + (cl-loop for (func-form type-spec) in comp-tests-type-spec-tests + do (comp-tests-check-ret-type-spec func-form type-spec))) + (defun comp-tests-pure-checker-1 (_) "Check that inside `comp-tests-pure-caller-f' `comp-tests-pure-callee-f' is folded." @@ -826,67 +930,6 @@ Return a list of results." (equal (comp-mvar-typeset mvar) comp-tests-cond-rw-expected-type)))))))) -(defvar comp-tests-cond-rw-0-var) -(comp-deftest cond-rw-0 () - "Check we do not miscompile some simple functions." - (let ((lexical-binding t)) - (let ((f (native-compile '(lambda (l) - (when (eq (car l) 'x) - (cdr l)))))) - (should (subr-native-elisp-p f)) - (should (eq (funcall f '(x . y)) 'y)) - (should (null (funcall f '(z . y))))) - - (should - (subr-native-elisp-p - (native-compile '(lambda () (if (eq comp-tests-cond-rw-0-var 123) 5 10))))))) - -(comp-deftest cond-rw-1 () - "Test cond-rw pass allow us to propagate type+val under `eq' tests." - (let ((lexical-binding t) - (comp-tests-cond-rw-expected-type '(integer)) - (comp-post-pass-hooks '((comp-final comp-tests-cond-rw-checker-type - comp-tests-cond-rw-checker-val)))) - (subr-native-elisp-p (native-compile '(lambda (x) (if (eq x 123) x t)))) - (subr-native-elisp-p (native-compile '(lambda (x) (if (eq 123 x) x t)))))) - -(comp-deftest cond-rw-2 () - "Test cond-rw pass allow us to propagate type+val under `=' tests." - (let ((lexical-binding t) - (comp-tests-cond-rw-expected-type '(integer)) - (comp-post-pass-hooks '((comp-final comp-tests-cond-rw-checker-type - comp-tests-cond-rw-checker-val)))) - (subr-native-elisp-p (native-compile '(lambda (x) (if (= x 123) x t)))))) - -(comp-deftest cond-rw-3 () - "Test cond-rw pass allow us to propagate type+val under `eql' tests." - (let ((lexical-binding t) - (comp-tests-cond-rw-expected-type '(integer)) - (comp-post-pass-hooks '((comp-final comp-tests-cond-rw-checker-type - comp-tests-cond-rw-checker-val)))) - (subr-native-elisp-p (native-compile '(lambda (x) (if (eql 123 x) x t)))))) - -(comp-deftest cond-rw-4 () - "Test cond-rw pass allow us to propagate type under `=' tests." - (let ((lexical-binding t) - (comp-tests-cond-rw-expected-type '(number)) - (comp-post-pass-hooks '((comp-final comp-tests-cond-rw-checker-type)))) - (subr-native-elisp-p (native-compile '(lambda (x y) (if (= x y) x t)))))) - -(comp-deftest cond-rw-5 () - "Test cond-rw pass allow us to propagate type under `=' tests." - (let ((comp-tests-cond-rw-checked-function #'comp-tests-cond-rw-4-f) - (comp-tests-cond-rw-expected-type '(integer)) - (comp-post-pass-hooks '((comp-final comp-tests-cond-rw-checker-type)))) - (eval '(defun comp-tests-cond-rw-4-f (x y) - (declare (speed 3)) - (if (= x (comp-hint-fixnum y)) - x - t)) - t) - (native-compile #'comp-tests-cond-rw-4-f) - (should (subr-native-elisp-p (symbol-function #'comp-tests-cond-rw-4-f))))) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Range propagation tests. ;; commit 93a80a4fae2b90471a3a3cf4f17751ce48f4af2f Author: Andrea Corallo Date: Wed Nov 11 17:23:25 2020 +0100 * Add nativecomp derived return type specifier computation support * lisp/emacs-lisp/comp.el (comp-post-pass-hooks): Nit. (comp-func): Add `ret-type-specifier' slot. (comp-ret-type-spec): New function. (comp-final): Call `comp-ret-type-spec'. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index e026d3b6ad..c863c29991 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -186,7 +186,7 @@ Can be one of: 'd-default', 'd-impure' or 'd-ephemeral'. See `comp-ctxt'.") "List of disabled passes. For internal use only by the testsuite.") -(defvar comp-post-pass-hooks () +(defvar comp-post-pass-hooks '() "Alist PASS FUNCTIONS. Each function in FUNCTIONS is run after PASS. Useful to hook into pass checkers.") @@ -421,7 +421,9 @@ CFG is mutated by a pass.") (speed nil :type number :documentation "Optimization level (see `comp-speed').") (pure nil :type boolean - :documentation "t if pure nil otherwise.")) + :documentation "t if pure nil otherwise.") + (ret-type-specifier '(t) :type list + :documentation "Derived return type specifier.")) (cl-defstruct (comp-func-l (:include comp-func)) "Lexically-scoped function." @@ -2768,6 +2770,53 @@ These are substituted with a normal 'set' op." ;;; Final pass specific code. +(defun comp-ret-type-spec (_ func) + "Compute type specifier for `comp-func' FUNC. +Set it into the `ret-type-specifier' slot." + (cl-loop + with res-typeset = nil + with res-valset = nil + with res-range = nil + for bb being the hash-value in (comp-func-blocks func) + do (cl-loop + for insn in (comp-block-insns bb) + do (pcase insn + (`(return ,mvar) + (when-let ((typeset (comp-mvar-typeset mvar))) + (setf res-typeset (comp-union-typesets res-typeset typeset))) + (when-let ((valset (comp-mvar-valset mvar))) + (setf res-valset (append res-valset valset))) + (when-let (range (comp-mvar-range mvar)) + (setf res-range (comp-range-union res-range range)))))) + finally + (when res-valset + (setf res-typeset + (cl-loop + with res = (copy-sequence res-typeset) + for type in res-typeset + for pred = (alist-get type comp-type-predicates) + when pred + do (cl-loop + for v in res-valset + when (funcall pred v) + do (setf res (remove type res))) + finally (cl-return res)))) + (setf res-range (cl-loop for (l . h) in res-range + for low = (if (numberp l) l '*) + for high = (if (numberp h) h '*) + collect `(integer ,low , high)) + res-valset (cl-remove-duplicates res-valset)) + (let ((res (append res-typeset + (when res-valset + `((member ,@res-valset))) + res-range))) + (setf (comp-func-ret-type-specifier func) + (if (> (length res) 1) + `(or ,@res) + (if (consp (car res)) + (car res) + res)))))) + (defun comp-finalize-container (cont) "Finalize data container CONT." (setf (comp-data-container-l cont) @@ -2867,6 +2916,7 @@ Prepare every function for final compilation and drive the C back-end." (defun comp-final (_) "Final pass driving the C back-end for code emission." + (maphash #'comp-ret-type-spec (comp-ctxt-funcs-h comp-ctxt)) (unless comp-dry-run (if noninteractive (comp-final1) commit 6b7c257e0bab055ab62ff15fb3d1e5fe352bc816 Author: Andrea Corallo Date: Wed Nov 11 15:54:58 2020 +0100 * Unline some functions to optimize bootstrap time * lisp/emacs-lisp/comp.el (comp-mvar-value-vld-p) (comp-mvar-value, comp-mvar-fixnum-p, comp-set-op-p) (comp-assign-op-p, comp-call-op-p, comp-type-hint-p) (comp-func-ret-typeset, comp-function-pure-p) (comp-alloc-class-to-container, comp-lex-byte-func-p) (comp-lap-eob-p, comp-lap-fall-through-p, comp-emit) (comp-emit-set-call, comp-mvar-propagate) (comp-function-foldable-p, comp-function-call-maybe-fold) (comp-trampoline-filename): Uninline functions. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 055adcc497..e026d3b6ad 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -449,7 +449,7 @@ Interg values are handled in the `range' slot.") (range '() :type list :documentation "Integer interval.")) -(defsubst comp-mvar-value-vld-p (mvar) +(defun comp-mvar-value-vld-p (mvar) "Return t if one single value can be extracted by the MVAR constrains." (or (= (length (comp-mvar-valset mvar)) 1) (let ((r (comp-mvar-range mvar))) @@ -461,7 +461,7 @@ Interg values are handled in the `range' slot.") (integerp high) (= low high))))))) -(defsubst comp-mvar-value (mvar) +(defun comp-mvar-value (mvar) "Return the constant value of MVAR. `comp-mvar-value-vld-p' *must* be satisfied before calling `comp-mvar-const'." @@ -477,7 +477,7 @@ Interg values are handled in the `range' slot.") (car v) (caar (comp-mvar-range mvar))))) -(defsubst comp-mvar-fixnum-p (mvar) +(defun comp-mvar-fixnum-p (mvar) "Return t if MVAR is certainly a fixnum." (when-let (range (comp-mvar-range mvar)) (let* ((low (caar range)) @@ -518,15 +518,15 @@ To be used by all entry points." ((null (native-comp-available-p)) (error "Cannot find libgccjit")))) -(defsubst comp-set-op-p (op) +(defun comp-set-op-p (op) "Assignment predicate for OP." (when (memq op comp-limple-sets) t)) -(defsubst comp-assign-op-p (op) +(defun comp-assign-op-p (op) "Assignment predicate for OP." (when (memq op comp-limple-assignments) t)) -(defsubst comp-call-op-p (op) +(defun comp-call-op-p (op) "Call predicate for OP." (when (memq op comp-limple-calls) t)) @@ -534,11 +534,11 @@ To be used by all entry points." "Limple INSN call predicate." (comp-call-op-p (car-safe insn))) -(defsubst comp-type-hint-p (func) +(defun comp-type-hint-p (func) "Type-hint predicate for function name FUNC." (when (memq func comp-type-hints) t)) -(defsubst comp-func-ret-typeset (func) +(defun comp-func-ret-typeset (func) "Return the typeset returned by function FUNC. " (or (alist-get func comp-known-ret-types) '(t))) @@ -564,13 +564,13 @@ To be used by all entry points." comp-ctxt)) (comp-ctxt-funcs-h comp-ctxt))) -(defsubst comp-function-pure-p (f) +(defun comp-function-pure-p (f) "Return t if F is pure." (or (get f 'pure) (when-let ((func (comp-symbol-func-to-fun f))) (comp-func-pure func)))) -(defsubst comp-alloc-class-to-container (alloc-class) +(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." (cl-struct-slot-value 'comp-ctxt (or alloc-class 'd-default) comp-ctxt)) @@ -682,7 +682,7 @@ instruction." ;;; spill-lap pass specific code. -(defsubst comp-lex-byte-func-p (f) +(defun comp-lex-byte-func-p (f) "Return t if F is a lexically-scoped byte compiled function." (and (byte-code-function-p f) (fixnump (aref f 0)))) @@ -945,12 +945,12 @@ Points to the next slot to be filled.") byte-switch byte-pushconditioncase) "LAP end of basic blocks op codes.") -(defsubst comp-lap-eob-p (inst) +(defun comp-lap-eob-p (inst) "Return t if INST closes the current basic blocks, nil otherwise." (when (memq (car inst) comp-lap-eob-ops) t)) -(defsubst comp-lap-fall-through-p (inst) +(defun comp-lap-fall-through-p (inst) "Return t if INST fall through, nil otherwise." (when (not (memq (car inst) '(byte-goto byte-return))) t)) @@ -1047,13 +1047,13 @@ If SSA non-nil populate it of m-var in ssa form." do (aset v i mvar) finally return v)) -(defsubst comp-emit (insn) +(defun comp-emit (insn) "Emit INSN into basic block BB." (let ((bb (comp-limplify-curr-block comp-pass))) (cl-assert (not (comp-block-closed bb))) (push insn (comp-block-insns bb)))) -(defsubst comp-emit-set-call (call) +(defun comp-emit-set-call (call) "Emit CALL assigning the result the the current slot frame. If the callee function is known to have a return type propagate it." (cl-assert call) @@ -2395,18 +2395,18 @@ Forward propagate immediate involed in assignments." (`(setimm ,lval ,v) (setf (comp-mvar-value lval) v)))))) -(defsubst comp-mvar-propagate (lval rval) +(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))) -(defsubst comp-function-foldable-p (f args) +(defun comp-function-foldable-p (f args) "Given function F called with ARGS return non-nil when optimizable." (and (comp-function-pure-p f) (cl-every #'comp-mvar-value-vld-p args))) -(defsubst comp-function-call-maybe-fold (insn f args) +(defun comp-function-call-maybe-fold (insn f args) "Given INSN when F is pure if all ARGS are known remove the function call." (cl-flet ((rewrite-insn-as-setimm (insn value) ;; See `comp-emit-setimm'. @@ -2925,7 +2925,7 @@ Prepare every function for final compilation and drive the C back-end." ;; Primitive funciton advice machinery -(defsubst comp-trampoline-filename (subr-name) +(defun comp-trampoline-filename (subr-name) "Given SUBR-NAME return the filename containing the trampoline." (concat (comp-c-func-name subr-name "subr--trampoline-" t) ".eln")) commit a214882354c7b0f4842698b5a1a65db6806853a2 Author: Andrea Corallo Date: Tue Nov 10 18:58:56 2020 +0100 * Add to elisp-mode `emacs-lisp-native-compile-and-load' * lisp/progmodes/elisp-mode.el (emacs-lisp--before-compile-buffer): New function. (emacs-lisp-byte-compile-and-load): Use the previous. (emacs-lisp-native-compile-and-load): New function. diff --git a/lisp/progmodes/elisp-mode.el b/lisp/progmodes/elisp-mode.el index 12788eacf1..dac3aaf2a5 100644 --- a/lisp/progmodes/elisp-mode.el +++ b/lisp/progmodes/elisp-mode.el @@ -186,19 +186,34 @@ All commands in `lisp-mode-shared-map' are inherited by this map.") (byte-compile-file buffer-file-name) (error "The buffer must be saved in a file first"))) -(defun emacs-lisp-byte-compile-and-load () - "Byte-compile the current file (if it has changed), then load compiled code." - (interactive) +(defun emacs-lisp--before-compile-buffer () + "Make sure the buffer is saved before compiling." (or buffer-file-name (error "The buffer must be saved in a file first")) - (require 'bytecomp) ;; Recompile if file or buffer has changed since last compilation. (if (and (buffer-modified-p) (y-or-n-p (format "Save buffer %s first? " (buffer-name)))) - (save-buffer)) + (save-buffer))) + +(defun emacs-lisp-byte-compile-and-load () + "Byte-compile the current file (if it has changed), then load compiled code." + (interactive) + (emacs-lisp--before-compile-buffer) + (require 'bytecomp) (byte-recompile-file buffer-file-name nil 0) (load buffer-file-name)) +(defun emacs-lisp-native-compile-and-load () + "Native-compile synchronously the current file (if it has changed). +Load the compiled code when finished. + +Use `emacs-lisp-byte-compile-and-load' in combination with +`comp-deferred-compilation' set to `t' to achieve asynchronous +native compilation." + (interactive) + (emacs-lisp--before-compile-buffer) + (load (native-compile buffer-file-name))) + (defun emacs-lisp-macroexpand () "Macroexpand the form after point. Comments in the form will be lost." commit 00b4e0a9bb0aa6fc6af997eeeff109cb263eddcf Author: Andrea Corallo Date: Sun Nov 8 12:16:34 2020 +0100 * Fix limple-mode for new type and range limple semantic * lisp/emacs-lisp/comp.el (comp-limple-branches, comp-limple-ops): New variables. (comp-limple-lock-keywords): Update value. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index ad0ac21389..055adcc497 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -242,6 +242,15 @@ Useful to hook into pass checkers.") direct-callref) "Limple operators use to call subrs.") +(defconst comp-limple-branches '(jump cond-jump) + "Limple operators use for conditional and unconditional branches.") + +(defconst comp-limple-ops `(,@comp-limple-calls + ,@comp-limple-assignments + ,@comp-limple-branches + return) + "All limple operators.") + (define-error 'native-compiler-error-dyn-func "can't native compile a non-lexically-scoped function" 'native-compiler-error) @@ -584,7 +593,8 @@ Assume allocation class 'd-default as default." (seq (or "entry_" "entry_fallback_" "bb_") (1+ num) (? "_latch"))))) (1 font-lock-constant-face)) - (,(rx "(" (group-n 1 (1+ (or word "-")))) + (,(rx-to-string + `(seq "(" (group-n 1 (or ,@(mapcar #'symbol-name comp-limple-ops))))) (1 font-lock-keyword-face))) "Highlights used by comp-limple-mode.") commit 175efec0732fc7317a444a2005f7b968a972b8e6 Author: Andrea Corallo Date: Wed Nov 11 16:17:03 2020 +0100 Add a nativecomp testcase Having this while re-debugging the boostrap would have saved few hours of debug so let's add it. * test/src/comp-tests.el (and-3): Add test. * test/src/comp-test-funcs.el (comp-test-and-3-var): New var. (comp-test-and-3-f): New function. diff --git a/test/src/comp-test-funcs.el b/test/src/comp-test-funcs.el index 35df46a9b8..1b0f3056b9 100644 --- a/test/src/comp-test-funcs.el +++ b/test/src/comp-test-funcs.el @@ -348,6 +348,12 @@ (defsubst comp-test-defsubst-f () t) +(defvar comp-test-and-3-var 1) +(defun comp-test-and-3-f (x) + (and (atom x) + comp-test-and-3-var + 2)) + ;;;;;;;;;;;;;;;;;;;; ;; Tromey's tests ;; diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 48687d9202..8bedad5db7 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -440,6 +440,10 @@ https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-03/msg00914.html." '(lambda () (delete-region (point-min) (point-max)))))))) +(comp-deftest and-3 () + (should (= (comp-test-and-3-f t) 2)) + (should (null (comp-test-and-3-f '(1 2))))) + ;;;;;;;;;;;;;;;;;;;;; ;; Tromey's tests. ;; commit e96cd4e82c9aca01f136ccdd7a3b0fbf2db01e50 Author: Andrea Corallo Date: Sat Nov 7 21:47:30 2020 +0100 Add initial nativecomp typeset and range propagation support This commit add an initial support for a better type propagation and integer range propagation. Each mvar can be now characterized by a set of types, a set of values and an integral range. * lisp/emacs-lisp/comp.el (comp-known-ret-types): Store into typeset and remove fixnum. (comp-known-ret-ranges, comp-type-predicates): New variables. (comp-ctxt): Remove supertype-memoize slot and add union-typesets-mem. (comp-mvar): Remove const-vld, constant, type slots. Add typeset, valset, range slots. (comp-mvar-value-vld-p, comp-mvar-value, comp-mvar-fixnum-p) (comp-mvar-symbol-p, comp-mvar-cons-p) (comp-mvar-type-hint-match-p, comp-func-ret-typeset) (comp-func-ret-range): New functions. (make-comp-mvar, make-comp-ssa-mvar): Update logic. (comp--typeof-types): New variable. (comp-supertypes, comp-common-supertype): Logic update. (comp-subtype-p, comp-union-typesets, comp-range-1+) (comp-range-1-, comp-range-<, comp-range-union) (comp-range-intersection): New functions. (comp-fwprop-prologue, comp-mvar-propagate) (comp-function-foldable-p, comp-function-call-maybe-fold) (comp-fwprop-insn, comp-call-optim-func, comp-finalize-relocs): Logic update. * src/comp.c (emit_mvar_rval, emit_call_with_type_hint) (emit_call2_with_type_hint): Logic update. * lisp/emacs-lisp/cl-preloaded.el (cl--typeof-types): Undo the add of fixnum and bignum as unnecessary. * test/src/comp-tests.el (comp-tests-mentioned-p-1, comp-tests-cond-rw-checker-val) (comp-tests-cond-rw-checker-type, cond-rw-1, cond-rw-2) (cond-rw-3, cond-rw-4, cond-rw-5): Update for new type interface. (range-simple-union, range-simple-intersection): New integer range tests. (union-types): New union type test. diff --git a/lisp/emacs-lisp/cl-preloaded.el b/lisp/emacs-lisp/cl-preloaded.el index b5dbcbda47..eed43c5ed3 100644 --- a/lisp/emacs-lisp/cl-preloaded.el +++ b/lisp/emacs-lisp/cl-preloaded.el @@ -52,8 +52,7 @@ (defconst cl--typeof-types ;; Hand made from the source code of `type-of'. - '((fixnum integer number number-or-marker atom) - (bignum integer number number-or-marker atom) + '((integer number number-or-marker atom) (symbol atom) (string array sequence atom) (cons list sequence) ;; Markers aren't `numberp', yet they are accepted wherever integers are diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 8bee8afeac..ad0ac21389 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -191,19 +191,31 @@ For internal use only by the testsuite.") Each function in FUNCTIONS is run after PASS. Useful to hook into pass checkers.") -(defconst comp-known-ret-types '((cons . cons) - (1+ . number) - (1- . number) - (+ . number) - (- . number) - (* . number) - (/ . number) - (% . number) +(defconst comp-known-ret-types '((cons . (cons)) + (1+ . (number)) + (1- . (number)) + (+ . (number)) + (- . (number)) + (* . (number)) + (/ . (number)) + (% . (number)) ;; Type hints - (comp-hint-fixnum . fixnum) - (comp-hint-cons . cons)) + (comp-hint-cons . (cons))) "Alist used for type propagation.") +(defconst comp-known-ret-ranges + `((comp-hint-fixnum . (,most-negative-fixnum . ,most-positive-fixnum))) + "Known returned ranges.") + +;; TODO fill it. +(defconst comp-type-predicates '((cons . consp) + (float . floatp) + (integer . integerp) + (number . numberp) + (string . stringp) + (symbol . symbolp)) + "Alist type -> predicate.") + (defconst comp-symbol-values-optimizable '(most-positive-fixnum most-negative-fixnum) "Symbol values we can resolve in the compile-time.") @@ -285,9 +297,9 @@ This is tipically for top-level forms other than defun.") :documentation "Relocated data not necessary after load.") (with-late-load nil :type boolean :documentation "When non-nil support late load.") - (supertype-memoize (make-hash-table :test #'equal) :type hash-table - :documentation "Serve memoization for - `comp-common-supertype'.")) + (union-typesets-mem (make-hash-table :test #'equal) :type hash-table + :documentation "Serve memoization for +`comp-union-typesets'.")) (cl-defstruct comp-args-base (min nil :type number @@ -419,14 +431,68 @@ CFG is mutated by a pass.") (slot nil :type (or fixnum symbol) :documentation "Slot number in the array if a number or 'scratch' for scratch slot.") - (const-vld nil :type boolean - :documentation "Valid signal for the following slot.") - (constant nil - :documentation "When const-vld non-nil this is used for holding - a value known at compile time.") - (type nil :type symbol - :documentation "When non-nil indicates the type when known at compile - time.")) + (typeset '(t) :type list + :documentation "List of possible types the mvar can assume. +Each element cannot be a subtype of any other element of this slot.") + (valset '() :type list + :documentation "List of possible values the mvar can assume. +Interg values are handled in the `range' slot.") + (range '() :type list + :documentation "Integer interval.")) + +(defsubst comp-mvar-value-vld-p (mvar) + "Return t if one single value can be extracted by the MVAR constrains." + (or (= (length (comp-mvar-valset mvar)) 1) + (let ((r (comp-mvar-range mvar))) + (and (= (length r) 1) + (let ((low (caar r)) + (high (cdar r))) + (and + (integerp low) + (integerp high) + (= low high))))))) + +(defsubst comp-mvar-value (mvar) + "Return the constant value of MVAR. +`comp-mvar-value-vld-p' *must* be satisfied before calling +`comp-mvar-const'." + (declare (gv-setter + (lambda (val) + `(if (integerp ,val) + (setf (comp-mvar-typeset ,mvar) nil + (comp-mvar-range ,mvar) (list (cons ,val ,val))) + (setf (comp-mvar-typeset ,mvar) nil + (comp-mvar-valset ,mvar) (list ,val)))))) + (let ((v (comp-mvar-valset mvar))) + (if (= (length v) 1) + (car v) + (caar (comp-mvar-range mvar))))) + +(defsubst comp-mvar-fixnum-p (mvar) + "Return t if MVAR is certainly a fixnum." + (when-let (range (comp-mvar-range mvar)) + (let* ((low (caar range)) + (high (cdar (last range)))) + (unless (or (eq low '-) + (< low most-negative-fixnum) + (eq high '+) + (> high most-positive-fixnum)) + t)))) + +(defsubst comp-mvar-symbol-p (mvar) + "Return t if MVAR is certainly a symbol." + (equal (comp-mvar-typeset mvar) '(symbol))) + +(defsubst comp-mvar-cons-p (mvar) + "Return t if MVAR is certainly a cons." + (equal (comp-mvar-typeset mvar) '(cons))) + +(defun comp-mvar-type-hint-match-p (mvar type-hint) + "Match MVAR against TYPE-HINT. +In use by the backend." + (cl-ecase type-hint + (cons (comp-mvar-cons-p mvar)) + (fixnum (comp-mvar-fixnum-p mvar)))) ;; Special vars used by some passes (defvar comp-func) @@ -463,6 +529,14 @@ To be used by all entry points." "Type-hint predicate for function name FUNC." (when (memq func comp-type-hints) t)) +(defsubst comp-func-ret-typeset (func) + "Return the typeset returned by function FUNC. " + (or (alist-get func comp-known-ret-types) '(t))) + +(defsubst comp-func-ret-range (func) + "Return the range returned by function FUNC. " + (alist-get func comp-known-ret-ranges)) + (defun comp-func-unique-in-cu-p (func) "Return t if FUNC is known to be unique in the current compilation unit." (if (symbolp func) @@ -943,10 +1017,14 @@ STACK-OFF is the index of the first slot frame involved." collect (comp-slot-n sp)))) (cl-defun make-comp-mvar (&key slot (constant nil const-vld) type) - (when const-vld - (comp-add-const-to-relocs constant)) - (make--comp-mvar :slot slot :const-vld const-vld :constant constant - :type type)) + "`comp-mvar' intitializer." + (let ((mvar (make--comp-mvar :slot slot))) + (when const-vld + (comp-add-const-to-relocs constant) + (setf (comp-mvar-value mvar) constant)) + (when type + (setf (comp-mvar-typeset mvar) (list type))) + mvar)) (defun comp-new-frame (size &optional ssa) "Return a clean frame of meta variables of size SIZE. @@ -1823,11 +1901,9 @@ blocks." ;; this form is called 'minimal SSA form'. ;; This pass should be run every time basic blocks or m-var are shuffled. -(cl-defun make-comp-ssa-mvar (&key slot (constant nil const-vld) type) - (let ((mvar (make--comp-mvar :slot slot - :const-vld const-vld - :constant constant - :type type))) +(cl-defun make-comp-ssa-mvar (&rest rest &key _slot _constant _type) + "Same as `make-comp-mvar' but set the `id' slot." + (let ((mvar (apply #'make-comp-mvar rest))) (setf (comp-mvar-id mvar) (sxhash-eq mvar)) mvar)) @@ -2130,19 +2206,18 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non-nil." ;; This is also responsible for removing function calls to pure functions if ;; possible. -(defsubst comp-strict-type-of (obj) - "Given OBJ return its type understanding fixnums." - ;; Should be certainly smarter but now we take advantages just from fixnums. - (if (fixnump obj) - 'fixnum - (type-of obj))) +(defconst comp--typeof-types (mapcar (lambda (x) + (append x '(t))) + cl--typeof-types) + ;; TODO can we just add t in `cl--typeof-types'? + "Like `cl--typeof-types' but with t as common supertype.") (defun comp-supertypes (type) "Return a list of pairs (supertype . hierarchy-level) for TYPE." (cl-loop named outer with found = nil - for l in cl--typeof-types + for l in comp--typeof-types do (cl-loop for x in l for i from (length l) downto 0 @@ -2165,10 +2240,105 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non-nil." (defun comp-common-supertype (&rest types) "Return the first common supertype of TYPES." - (or (gethash types (comp-ctxt-supertype-memoize comp-ctxt)) - (puthash types - (cl-reduce #'comp-common-supertype-2 types) - (comp-ctxt-supertype-memoize comp-ctxt)))) + (cl-reduce #'comp-common-supertype-2 types)) + +(defsubst comp-subtype-p (type1 type2) + "Return t if TYPE1 is a subtype of TYPE1 or nil otherwise." + (eq (comp-common-supertype-2 type1 type2) type2)) + +(defun comp-union-typesets (&rest typesets) + "Union types present into TYPESETS." + (or (gethash typesets (comp-ctxt-union-typesets-mem comp-ctxt)) + (puthash typesets + (cl-loop + with types = (apply #'append typesets) + with res = '() + for lane in comp--typeof-types + do (cl-loop + with last = nil + for x in lane + when (memq x types) + do (setf last x) + finally (when last + (push last res))) + finally (cl-return (cl-remove-duplicates res))) + (comp-ctxt-union-typesets-mem comp-ctxt)))) + +(defsubst comp-range-1+ (x) + (if (symbolp x) + x + (1+ x))) + +(defsubst comp-range-1- (x) + (if (symbolp x) + x + (1- x))) + +(defsubst comp-range-< (x y) + (cond + ((eq x '+) nil) + ((eq x '-) t) + ((eq y '+) t) + ((eq y '-) nil) + (t (< x y)))) + +(defun comp-range-union (&rest ranges) + "Combine integer intervals RANGES by union operation." + (cl-loop + with all-ranges = (apply #'append ranges) + with lows = (mapcar (lambda (x) + (cons (comp-range-1- (car x)) 'l)) + all-ranges) + with highs = (mapcar (lambda (x) + (cons (cdr x) 'h)) + all-ranges) + with nest = 0 + with low = nil + with res = () + for (i . x) in (cl-sort (nconc lows highs) #'comp-range-< :key #'car) + if (eq x 'l) + do + (when (zerop nest) + (setf low i)) + (cl-incf nest) + else + do + (when (= nest 1) + (push `(,(comp-range-1+ low) . ,i) res)) + (cl-decf nest) + finally (cl-return (reverse res)))) + +(defun comp-range-intersection (&rest ranges) + "Combine integer intervals RANGES by intersecting." + (cl-loop + with all-ranges = (apply #'append ranges) + with n-ranges = (length ranges) + with lows = (mapcar (lambda (x) + (cons (car x) 'l)) + all-ranges) + with highs = (mapcar (lambda (x) + (cons (cdr x) 'h)) + all-ranges) + with nest = 0 + with low = nil + with res = () + initially (when (cl-some #'null ranges) + ;; Intersecting with a null range always results in a + ;; null range. + (cl-return '())) + for (i . x) in (cl-sort (nconc lows highs) #'comp-range-< :key #'car) + if (eq x 'l) + do + (cl-incf nest) + (when (= nest n-ranges) + (setf low i)) + else + do + (when (= nest n-ranges) + (push `(,low . ,i) + res)) + (cl-decf nest) + finally (cl-return (reverse res)))) (defun comp-copy-insn (insn) "Deep copy INSN." @@ -2213,20 +2383,18 @@ Forward propagate immediate involed in assignments." for insn in (comp-block-insns b) do (pcase insn (`(setimm ,lval ,v) - (setf (comp-mvar-const-vld lval) t - (comp-mvar-constant lval) v - (comp-mvar-type lval) (comp-strict-type-of v))))))) + (setf (comp-mvar-value lval) v)))))) (defsubst comp-mvar-propagate (lval rval) "Propagate into LVAL properties of RVAL." - (setf (comp-mvar-const-vld lval) (comp-mvar-const-vld rval) - (comp-mvar-constant lval) (comp-mvar-constant rval) - (comp-mvar-type lval) (comp-mvar-type 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))) (defsubst comp-function-foldable-p (f args) "Given function F called with ARGS return non-nil when optimizable." - (and (cl-every #'comp-mvar-const-vld args) - (comp-function-pure-p f))) + (and (comp-function-pure-p f) + (cl-every #'comp-mvar-value-vld-p args))) (defsubst comp-function-call-maybe-fold (insn f args) "Given INSN when F is pure if all ARGS are known remove the function call." @@ -2238,10 +2406,10 @@ Forward propagate immediate involed in assignments." (cond ((eq f 'symbol-value) (when-let* ((arg0 (car args)) - (const (comp-mvar-const-vld arg0)) - (ok-to-optim (member (comp-mvar-constant arg0) + (const (comp-mvar-value-vld-p arg0)) + (ok-to-optim (member (comp-mvar-value arg0) comp-symbol-values-optimizable))) - (rewrite-insn-as-setimm insn (symbol-value (comp-mvar-constant + (rewrite-insn-as-setimm insn (symbol-value (comp-mvar-value (car args)))))) ((comp-function-foldable-p f args) (ignore-errors @@ -2254,7 +2422,7 @@ Forward propagate immediate involed in assignments." ;; and know to be pure. (comp-func-byte-func f-in-ctxt) f)) - (value (comp-apply-in-env f (mapcar #'comp-mvar-constant args)))) + (value (comp-apply-in-env f (mapcar #'comp-mvar-value args)))) (rewrite-insn-as-setimm insn value))))))) (defun comp-fwprop-insn (insn) @@ -2263,13 +2431,19 @@ Forward propagate immediate involed in assignments." (`(set ,lval ,rval) (pcase rval (`(,(or 'call 'callref) ,f . ,args) - (setf (comp-mvar-type lval) - (alist-get f comp-known-ret-types)) + (if-let ((range (comp-func-ret-range f))) + (setf (comp-mvar-range lval) (list range) + (comp-mvar-typeset lval) nil) + (setf (comp-mvar-typeset lval) + (comp-func-ret-typeset f))) (comp-function-call-maybe-fold insn f args)) (`(,(or 'direct-call 'direct-callref) ,f . ,args) (let ((f (comp-func-name (gethash f (comp-ctxt-funcs-h comp-ctxt))))) - (setf (comp-mvar-type lval) - (alist-get f comp-known-ret-types)) + (if-let ((range (comp-func-ret-range f))) + (setf (comp-mvar-range lval) (list range) + (comp-mvar-typeset lval) nil) + (setf (comp-mvar-typeset lval) + (comp-func-ret-typeset f))) (comp-function-call-maybe-fold insn f args))) (_ (comp-mvar-propagate lval rval)))) @@ -2278,31 +2452,46 @@ Forward propagate immediate involed in assignments." ('eq (comp-mvar-propagate lval rval)) ((or 'eql 'equal) - (if (memq (comp-mvar-type rval) '(symbol fixnum)) + (if (or (comp-mvar-symbol-p rval) + (comp-mvar-fixnum-p rval)) (comp-mvar-propagate lval rval) - (setf (comp-mvar-type lval) (comp-mvar-type rval)))) + (setf (comp-mvar-typeset lval) (comp-mvar-typeset rval)))) ('= - (if (eq (comp-mvar-type rval) 'fixnum) + (if (comp-mvar-fixnum-p rval) (comp-mvar-propagate lval rval) - (setf (comp-mvar-type lval) 'number))))) + (setf (comp-mvar-typeset lval) + (unless (comp-mvar-range rval) + '(number))))))) (`(setimm ,lval ,v) - (setf (comp-mvar-const-vld lval) t - (comp-mvar-constant lval) v - (comp-mvar-type lval) (comp-strict-type-of v))) + (setf (comp-mvar-value lval) v)) (`(phi ,lval . ,rest) - (let ((rvals (mapcar #'car rest))) - ;; Forward const prop here. - (when-let* ((vld (cl-every #'comp-mvar-const-vld rvals)) - (consts (mapcar #'comp-mvar-constant rvals)) - (x (car consts)) - (equals (cl-every (lambda (y) (equal x y)) consts))) - (setf (comp-mvar-const-vld lval) t - (comp-mvar-constant lval) x)) - ;; Forward type propagation. - (when-let* ((types (mapcar #'comp-mvar-type rvals)) - (non-empty (cl-notany #'null types)) - (x (comp-common-supertype types))) - (setf (comp-mvar-type lval) x)))))) + (let* ((rvals (mapcar #'car rest)) + (values (mapcar #'comp-mvar-valset rvals)) + (from-latch (cl-some + (lambda (x) + (comp-latch-p + (gethash (cdr x) + (comp-func-blocks comp-func)))) + rest))) + + ;; Type propagation. + (setf (comp-mvar-typeset lval) + (apply #'comp-union-typesets (mapcar #'comp-mvar-typeset rvals))) + ;; Value propagation. + (setf (comp-mvar-valset lval) + (when (cl-every #'consp values) + ;; TODO memoize? + (cl-remove-duplicates (apply #'append values) + :test #'equal))) + ;; Range propagation + (setf (comp-mvar-range lval) + (when (and (not from-latch) + (cl-notany (lambda (x) + (comp-subtype-p 'integer x)) + (comp-mvar-typeset lval))) + ;; TODO memoize? + (apply #'comp-range-union + (mapcar #'comp-mvar-range rvals)))))))) (defun comp-fwprop* () "Propagate for set* and phi operands. @@ -2416,11 +2605,11 @@ FUNCTION can be a function-name or byte compiled function." (pcase insn (`(set ,lval (callref funcall ,f . ,rest)) (when-let ((new-form (comp-call-optim-form-call - (comp-mvar-constant f) rest))) + (comp-mvar-value f) rest))) (setf insn `(set ,lval ,new-form)))) (`(callref funcall ,f . ,rest) (when-let ((new-form (comp-call-optim-form-call - (comp-mvar-constant f) rest))) + (comp-mvar-value f) rest))) (setf insn new-form))))))) (defun comp-call-optim (_) @@ -2639,7 +2828,8 @@ Update all insn accordingly." do (cl-assert (null (gethash idx reverse-h))) (cl-assert (fixnump idx)) - (setf (comp-mvar-constant mvar) idx) + (setf (comp-mvar-valset mvar) () + (comp-mvar-range mvar) (list (cons idx idx))) (puthash idx t reverse-h)))) (defun comp-compile-ctxt-to-file (name) diff --git a/src/comp.c b/src/comp.c index cb5f1a1ce9..0d46428185 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1845,32 +1845,32 @@ emit_PURE_P (gcc_jit_rvalue *ptr) static gcc_jit_rvalue * emit_mvar_rval (Lisp_Object mvar) { - Lisp_Object const_vld = CALL1I (comp-mvar-const-vld, mvar); - Lisp_Object constant = CALL1I (comp-mvar-constant, mvar); + Lisp_Object const_vld = CALL1I (comp-mvar-value-vld-p, mvar); if (!NILP (const_vld)) { + Lisp_Object value = CALL1I (comp-mvar-value, mvar); if (comp.debug > 1) { Lisp_Object func = - Fgethash (constant, + Fgethash (value, CALL1I (comp-ctxt-byte-func-to-func-h, Vcomp_ctxt), Qnil); emit_comment ( SSDATA ( Fprin1_to_string ( - NILP (func) ? constant : CALL1I (comp-func-c-name, func), + NILP (func) ? value : CALL1I (comp-func-c-name, func), Qnil))); } - if (FIXNUMP (constant)) + if (FIXNUMP (value)) { /* We can still emit directly objects that are self-contained in a word (read fixnums). */ - return emit_rvalue_from_lisp_obj (constant); + return emit_rvalue_from_lisp_obj (value); } /* Other const objects are fetched from the reloc array. */ - return emit_lisp_obj_rval (constant); + return emit_lisp_obj_rval (value); } return gcc_jit_lvalue_as_rvalue (emit_mvar_lval (mvar)); @@ -2371,12 +2371,13 @@ static gcc_jit_rvalue * emit_call_with_type_hint (gcc_jit_function *func, Lisp_Object insn, Lisp_Object type) { - bool type_hint = EQ (CALL1I (comp-mvar-type, SECOND (insn)), type); + bool hint_match = + !NILP (CALL2I (comp-mvar-type-hint-match-p, SECOND (insn), type)); gcc_jit_rvalue *args[] = { emit_mvar_rval (SECOND (insn)), gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.bool_type, - type_hint) }; + hint_match) }; return gcc_jit_context_new_call (comp.ctxt, NULL, func, 2, args); } @@ -2386,13 +2387,14 @@ static gcc_jit_rvalue * emit_call2_with_type_hint (gcc_jit_function *func, Lisp_Object insn, Lisp_Object type) { - bool type_hint = EQ (CALL1I (comp-mvar-type, SECOND (insn)), type); + bool hint_match = + !NILP (CALL2I (comp-mvar-type-hint-match-p, SECOND (insn), type)); gcc_jit_rvalue *args[] = { emit_mvar_rval (SECOND (insn)), emit_mvar_rval (THIRD (insn)), gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.bool_type, - type_hint) }; + hint_match) }; return gcc_jit_context_new_call (comp.ctxt, NULL, func, 3, args); } diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 21c8abad03..48687d9202 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -37,7 +37,7 @@ (defconst comp-test-dyn-src (concat comp-test-directory "comp-test-funcs-dyn.el")) -(when (boundp 'comp-ctxt) +(when (featurep 'nativecomp) (message "Compiling tests...") (load (native-compile comp-test-src)) (load (native-compile comp-test-dyn-src))) @@ -676,8 +676,8 @@ https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-03/msg00914.html." (cl-loop for y in insn when (cond ((consp y) (comp-tests-mentioned-p x y)) - ((and (comp-mvar-p y) (comp-mvar-const-vld y)) - (equal (comp-mvar-constant y) x)) + ((and (comp-mvar-p y) (comp-mvar-value-vld-p y)) + (equal (comp-mvar-value y) x)) (t (equal x y))) return t)) @@ -804,8 +804,8 @@ Return a list of results." (lambda (insn) (pcase insn (`(return ,mvar) - (and (comp-mvar-const-vld mvar) - (= (comp-mvar-constant mvar) 123))))))))) + (and (comp-mvar-value-vld-p mvar) + (eql (comp-mvar-value mvar) 123))))))))) (defvar comp-tests-cond-rw-expected-type nil "Type to expect in `comp-tests-cond-rw-checker-type'.") @@ -819,7 +819,8 @@ Return a list of results." (lambda (insn) (pcase insn (`(return ,mvar) - (eq (comp-mvar-type mvar) comp-tests-cond-rw-expected-type)))))))) + (equal (comp-mvar-typeset mvar) + comp-tests-cond-rw-expected-type)))))))) (defvar comp-tests-cond-rw-0-var) (comp-deftest cond-rw-0 () @@ -839,40 +840,39 @@ Return a list of results." (comp-deftest cond-rw-1 () "Test cond-rw pass allow us to propagate type+val under `eq' tests." (let ((lexical-binding t) - (comp-tests-cond-rw-expected-type 'fixnum) - (comp-post-pass-hooks '((comp-final comp-tests-cond-rw-checker-type) - (comp-final comp-tests-cond-rw-checker-val)))) + (comp-tests-cond-rw-expected-type '(integer)) + (comp-post-pass-hooks '((comp-final comp-tests-cond-rw-checker-type + comp-tests-cond-rw-checker-val)))) (subr-native-elisp-p (native-compile '(lambda (x) (if (eq x 123) x t)))) (subr-native-elisp-p (native-compile '(lambda (x) (if (eq 123 x) x t)))))) (comp-deftest cond-rw-2 () "Test cond-rw pass allow us to propagate type+val under `=' tests." (let ((lexical-binding t) - (comp-tests-cond-rw-expected-type 'fixnum) - (comp-post-pass-hooks '((comp-final comp-tests-cond-rw-checker-type) - (comp-final comp-tests-cond-rw-checker-val)))) + (comp-tests-cond-rw-expected-type '(integer)) + (comp-post-pass-hooks '((comp-final comp-tests-cond-rw-checker-type + comp-tests-cond-rw-checker-val)))) (subr-native-elisp-p (native-compile '(lambda (x) (if (= x 123) x t)))))) (comp-deftest cond-rw-3 () "Test cond-rw pass allow us to propagate type+val under `eql' tests." (let ((lexical-binding t) - (comp-tests-cond-rw-expected-type 'fixnum) - (comp-post-pass-hooks '((comp-final comp-tests-cond-rw-checker-type) - (comp-final comp-tests-cond-rw-checker-val)))) + (comp-tests-cond-rw-expected-type '(integer)) + (comp-post-pass-hooks '((comp-final comp-tests-cond-rw-checker-type + comp-tests-cond-rw-checker-val)))) (subr-native-elisp-p (native-compile '(lambda (x) (if (eql 123 x) x t)))))) (comp-deftest cond-rw-4 () "Test cond-rw pass allow us to propagate type under `=' tests." (let ((lexical-binding t) - (comp-tests-cond-rw-expected-type 'number) + (comp-tests-cond-rw-expected-type '(number)) (comp-post-pass-hooks '((comp-final comp-tests-cond-rw-checker-type)))) (subr-native-elisp-p (native-compile '(lambda (x y) (if (= x y) x t)))))) (comp-deftest cond-rw-5 () "Test cond-rw pass allow us to propagate type under `=' tests." - (let ((lexical-binding t) - (comp-tests-cond-rw-checked-function #'comp-tests-cond-rw-4-f) - (comp-tests-cond-rw-expected-type 'fixnum) + (let ((comp-tests-cond-rw-checked-function #'comp-tests-cond-rw-4-f) + (comp-tests-cond-rw-expected-type '(integer)) (comp-post-pass-hooks '((comp-final comp-tests-cond-rw-checker-type)))) (eval '(defun comp-tests-cond-rw-4-f (x y) (declare (speed 3)) @@ -883,4 +883,48 @@ Return a list of results." (native-compile #'comp-tests-cond-rw-4-f) (should (subr-native-elisp-p (symbol-function #'comp-tests-cond-rw-4-f))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Range propagation tests. ;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(comp-deftest range-simple-union () + (should (equal (comp-range-union '((-1 . 0)) '((3 . 4))) + '((-1 . 0) (3 . 4)))) + (should (equal (comp-range-union '((-1 . 2)) '((3 . 4))) + '((-1 . 4)))) + (should (equal (comp-range-union '((-1 . 3)) '((3 . 4))) + '((-1 . 4)))) + (should (equal (comp-range-union '((-1 . 4)) '((3 . 4))) + '((-1 . 4)))) + (should (equal (comp-range-union '((-1 . 5)) '((3 . 4))) + '((-1 . 5)))) + (should (equal (comp-range-union '((-1 . 0)) '()) + '((-1 . 0))))) + +(comp-deftest range-simple-intersection () + (should (equal (comp-range-intersection '((-1 . 0)) '((3 . 4))) + '())) + (should (equal (comp-range-intersection '((-1 . 2)) '((3 . 4))) + '())) + (should (equal (comp-range-intersection '((-1 . 3)) '((3 . 4))) + '((3 . 3)))) + (should (equal (comp-range-intersection '((-1 . 4)) '((3 . 4))) + '((3 . 4)))) + (should (equal (comp-range-intersection '((-1 . 5)) '((3 . 4))) + '((3 . 4)))) + (should (equal (comp-range-intersection '((-1 . 0)) '()) + '()))) + +(comp-deftest union-types () + (let ((comp-ctxt (make-comp-ctxt))) + (should (equal (comp-union-typesets '(integer) '(number)) + '(number))) + (should (equal (comp-union-typesets '(integer symbol) '(number)) + '(symbol number))) + (should (equal (comp-union-typesets '(integer symbol) '(number list)) + '(list symbol number))) + (should (equal (comp-union-typesets '(integer symbol) '()) + '(symbol integer))))) + ;;; comp-tests.el ends here commit c3d0e2a09fd72aa9209dda3057bbb02f6a3b3df6 Author: Andrea Corallo Date: Sun Nov 8 10:40:05 2020 +0100 * Rename two nativecomp functions * lisp/emacs-lisp/comp.el (comp-function-foldable-p): Rename from comp-function-optimizable-p. (comp-function-call-maybe-fold): Same from comp-function-call-maybe-fold. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 887a6a503e..8bee8afeac 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2223,12 +2223,12 @@ Forward propagate immediate involed in assignments." (comp-mvar-constant lval) (comp-mvar-constant rval) (comp-mvar-type lval) (comp-mvar-type rval))) -(defsubst comp-function-optimizable-p (f args) +(defsubst comp-function-foldable-p (f args) "Given function F called with ARGS return non-nil when optimizable." (and (cl-every #'comp-mvar-const-vld args) (comp-function-pure-p f))) -(defsubst comp-function-call-maybe-remove (insn f args) +(defsubst comp-function-call-maybe-fold (insn f args) "Given INSN when F is pure if all ARGS are known remove the function call." (cl-flet ((rewrite-insn-as-setimm (insn value) ;; See `comp-emit-setimm'. @@ -2243,7 +2243,7 @@ Forward propagate immediate involed in assignments." comp-symbol-values-optimizable))) (rewrite-insn-as-setimm insn (symbol-value (comp-mvar-constant (car args)))))) - ((comp-function-optimizable-p f args) + ((comp-function-foldable-p f args) (ignore-errors ;; No point to complain here in case of error because we ;; should do basic block pruning in order to be sure that this @@ -2265,12 +2265,12 @@ Forward propagate immediate involed in assignments." (`(,(or 'call 'callref) ,f . ,args) (setf (comp-mvar-type lval) (alist-get f comp-known-ret-types)) - (comp-function-call-maybe-remove insn f args)) + (comp-function-call-maybe-fold insn f args)) (`(,(or 'direct-call 'direct-callref) ,f . ,args) (let ((f (comp-func-name (gethash f (comp-ctxt-funcs-h comp-ctxt))))) (setf (comp-mvar-type lval) (alist-get f comp-known-ret-types)) - (comp-function-call-maybe-remove insn f args))) + (comp-function-call-maybe-fold insn f args))) (_ (comp-mvar-propagate lval rval)))) (`(assume ,lval ,rval ,kind) commit e20cdf937e74ebcaa2c6dabb63be1c20a6ea44f6 Author: Andrea Corallo Date: Sun Nov 8 20:45:43 2020 +0100 * lisp/emacs-lisp/comp.el (comp-fwprop-insn): Fix phi function. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index c837e02060..887a6a503e 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2289,19 +2289,20 @@ Forward propagate immediate involed in assignments." (setf (comp-mvar-const-vld lval) t (comp-mvar-constant lval) v (comp-mvar-type lval) (comp-strict-type-of v))) - (`(phi (,lval . _) . ,rest) - ;; Forward const prop here. - (when-let* ((vld (cl-every #'comp-mvar-const-vld rest)) - (consts (mapcar #'comp-mvar-constant rest)) - (x (car consts)) - (equals (cl-every (lambda (y) (equal x y)) consts))) - (setf (comp-mvar-const-vld lval) t - (comp-mvar-constant lval) x)) - ;; Forward type propagation. - (when-let* ((types (mapcar #'comp-mvar-type rest)) - (non-empty (cl-notany #'null types)) - (x (comp-common-supertype types))) - (setf (comp-mvar-type lval) x))))) + (`(phi ,lval . ,rest) + (let ((rvals (mapcar #'car rest))) + ;; Forward const prop here. + (when-let* ((vld (cl-every #'comp-mvar-const-vld rvals)) + (consts (mapcar #'comp-mvar-constant rvals)) + (x (car consts)) + (equals (cl-every (lambda (y) (equal x y)) consts))) + (setf (comp-mvar-const-vld lval) t + (comp-mvar-constant lval) x)) + ;; Forward type propagation. + (when-let* ((types (mapcar #'comp-mvar-type rvals)) + (non-empty (cl-notany #'null types)) + (x (comp-common-supertype types))) + (setf (comp-mvar-type lval) x)))))) (defun comp-fwprop* () "Propagate for set* and phi operands. commit a5408d5715de5ee9b6858c6eb0638043f4cdb136 Author: Andrea Corallo Date: Sat Nov 7 21:00:14 2020 +0100 * lisp/emacs-lisp/comp.el (comp-common-supertype-2): Fix null intersection diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 9fbf60c96c..c837e02060 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2155,14 +2155,13 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non-nil." (defun comp-common-supertype-2 (type1 type2) "Return the first common supertype of TYPE1 TYPE2." - (car (cl-reduce (lambda (x y) - (if (> (cdr x) (cdr y)) - x - y)) - (cl-intersection - (comp-supertypes type1) - (comp-supertypes type2) - :key #'car)))) + (when-let ((types (cl-intersection + (comp-supertypes type1) + (comp-supertypes type2) + :key #'car))) + (car (cl-reduce (lambda (x y) + (if (> (cdr x) (cdr y)) x y)) + types)))) (defun comp-common-supertype (&rest types) "Return the first common supertype of TYPES." commit 04a073f4bf1cc31a3a2606468b0e017b69d7ff39 Author: Andrea Corallo Date: Sat Nov 7 16:03:14 2020 +0100 * Allow for manually bumbing new native compiler ABI versions * src/comp.c (ABI_VERSION): Define macro. (hash_native_abi): Include ABI_VERSION in the hashing. (syms_of_comp): Tweak docstring. diff --git a/src/comp.c b/src/comp.c index 05ec073c1f..cb5f1a1ce9 100644 --- a/src/comp.c +++ b/src/comp.c @@ -406,6 +406,9 @@ load_gccjit_if_necessary (bool mandatory) } +/* Increase this number to force a new Vcomp_abi_hash to be generated. */ +#define ABI_VERSION "0" + /* C symbols emitted for the load relocation mechanism. */ #define CURRENT_THREAD_RELOC_SYM "current_thread_reloc" #define PURE_RELOC_SYM "pure_reloc" @@ -778,8 +781,10 @@ hash_native_abi (void) eassert (NILP (Vcomp_abi_hash)); Vcomp_abi_hash = - comp_hash_string (Fmapconcat (intern_c_string ("subr-name"), - Vcomp_subr_list, build_string (""))); + comp_hash_string ( + concat2 (build_string (ABI_VERSION), + Fmapconcat (intern_c_string ("subr-name"), + Vcomp_subr_list, build_string ("")))); Lisp_Object separator = build_string ("-"); Vcomp_native_version_dir = concat3 (Vemacs_version, @@ -5262,7 +5267,7 @@ native compiled one. */); DEFVAR_LISP ("comp-subr-list", Vcomp_subr_list, doc: /* List of all defined subrs. */); DEFVAR_LISP ("comp-abi-hash", Vcomp_abi_hash, - doc: /* String signing the ABI exposed to .eln files. */); + doc: /* String signing the .eln files ABI. */); Vcomp_abi_hash = Qnil; DEFVAR_LISP ("comp-native-version-dir", Vcomp_native_version_dir, doc: /* Directory in use to disambiguate eln compatibility. */); commit 75e8ee728fdda91a9eca7f3db24b639e8036f7e4 Merge: 6c271ffaa8 e8f5657bc7 Author: Andrea Corallo Date: Sat Nov 7 16:21:36 2020 +0100 Merge remote-tracking branch 'savannah/master' into HEAD commit 6c271ffaa808c602e177db4bd2297ff81112147e Author: Andrea Corallo Date: Sat Nov 7 12:31:37 2020 +0100 * Fix non native compiled build * lisp/emacs-lisp/advice.el (ad-add-advice): Do not try to install trampolines in vanilla builds. diff --git a/lisp/emacs-lisp/advice.el b/lisp/emacs-lisp/advice.el index 509e255191..086aa98bb0 100644 --- a/lisp/emacs-lisp/advice.el +++ b/lisp/emacs-lisp/advice.el @@ -2077,7 +2077,8 @@ mapped to the closest extremal position). If FUNCTION was not advised already, its advice info will be initialized. Redefining a piece of advice whose name is part of the cache-id will clear the cache." - (when (subr-primitive-p (symbol-function function)) + (when (and (featurep 'nativecomp) + (subr-primitive-p (symbol-function function))) (comp-subr-trampoline-install function)) (cond ((not (ad-is-advised function)) (ad-initialize-advice-info function) commit 4a69e953f34d504809b94a0c4634444d34100039 Author: Andrea Corallo Date: Sat Nov 7 00:13:01 2020 +0100 Allow for native compilation qualities to be specified per input file * lisp/emacs-lisp/bytecomp.el (byte-native-qualities): Define variable. (byte-compile-from-buffer): Spill compilation qualities. * lisp/emacs-lisp/comp.el (comp-speed, comp-debug): Make them file local variables. (comp-ctxt): Add `speed' and `debug' slots. (comp-spill-speed, comp-spill-lap-function): Make use of these. (comp-spill-lap-function): Spill qualities from `byte-native-qualities'. (comp-limplify-top-level): Do not use `comp-speed' but ctxt value unstead. (comp-final): Do not propagate qualities as they are already in the `comp-ctxt'. (comp--native-compile): Close on `byte-native-qualities'. * src/comp.c (comp_t): Add 'speed' and 'debug' fields. (emit_comment, emit_mvar_rval, emit_static_object) (emit_ctxt_code, Fcomp__init_ctxt): Use these instead of the global variables. (Fcomp__compile_ctxt_to_file): Set comp.speed and comp.debug and use them. diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index a3c830e60d..5508a60c44 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -598,6 +598,8 @@ Each element is (INDEX . VALUE)") (defvar byte-native-compiling nil "Non nil while native compiling.") +(defvar byte-native-qualities nil + "To spill default qualities from the compiled file.") (defvar byte-native-for-bootstrap nil "Non nil while compiling for bootstrap." ;; During boostrap we produce both the .eln and the .elc together. @@ -2216,6 +2218,11 @@ With argument ARG, insert value in current buffer after the form." (setq byte-compile-unresolved-functions nil) (setq byte-compile-noruntime-functions nil) (setq byte-compile-new-defuns nil) + (when byte-native-compiling + (defvar comp-speed) + (push `(comp-speed . ,comp-speed) byte-native-qualities) + (defvar comp-debug) + (push `(comp-debug . ,comp-debug) byte-native-qualities)) ;; Compile the forms from the input buffer. (while (progn diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index bb32aefcad..9fbf60c96c 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -51,6 +51,7 @@ - 3 max optimization level, to be used only when necessary. Warning: the compiler is free to perform dangerous optimizations." :type 'number + :safe #'numberp :group 'comp) (defcustom comp-debug 0 @@ -62,6 +63,7 @@ This intended for debugging the compiler itself. - 2 dump gcc passes and libgccjit log file. - 3 dump libgccjit reproducers." :type 'number + :safe #'numberp :group 'comp) (defcustom comp-verbose 0 @@ -256,6 +258,10 @@ Useful to hook into pass checkers.") "Lisp side of the compiler context." (output nil :type string :documentation "Target output file-name for the compilation.") + (speed comp-speed :type number + :documentation "Default speed for this compilation unit.") + (debug comp-debug :type number + :documentation "Default debug level for this compilation unit.") (top-level-forms () :type list :documentation "List of spilled top level forms.") (funcs-h (make-hash-table :test #'equal) :type hash-table @@ -605,7 +611,7 @@ instruction." (defun comp-spill-speed (function-name) "Return the speed for FUNCTION-NAME." (or (comp-spill-decl-spec function-name 'speed) - comp-speed)) + (comp-ctxt-speed comp-ctxt))) ;; Autoloaded as might be used by `disassemble-internal'. ;;;###autoload @@ -723,11 +729,11 @@ clashes." (make-comp-func-l :c-name c-name :doc (documentation form t) :int-spec (interactive-form form) - :speed comp-speed) + :speed (comp-ctxt-speed comp-ctxt)) (make-comp-func-d :c-name c-name :doc (documentation form t) :int-spec (interactive-form form) - :speed comp-speed)))) + :speed (comp-ctxt-speed comp-ctxt))))) (let ((lap (byte-to-native-lambda-lap (gethash (aref byte-code 1) byte-to-native-lambdas-h)))) @@ -798,7 +804,11 @@ clashes." filename (when byte-native-for-bootstrap (car (last comp-eln-load-path)))))) - (setf (comp-ctxt-top-level-forms comp-ctxt) + (setf (comp-ctxt-speed comp-ctxt) (alist-get 'comp-speed + byte-native-qualities) + (comp-ctxt-debug comp-ctxt) (alist-get 'comp-debug + byte-native-qualities) + (comp-ctxt-top-level-forms comp-ctxt) (cl-loop for form in (reverse byte-to-native-top-level-forms) collect @@ -1575,7 +1585,7 @@ into the C code forwarding the compilation unit." ;; the last function being ;; registered. :frame-size 2 - :speed comp-speed)) + :speed (comp-ctxt-speed comp-ctxt))) (comp-func func) (comp-pass (make-comp-limplify :curr-block (make--comp-block-lap -1 0 'top-level) @@ -2670,9 +2680,7 @@ Prepare every function for final compilation and drive the C back-end." (print-circle t) (expr `(progn (require 'comp) - (setf comp-speed ,comp-speed - comp-debug ,comp-debug - comp-verbose ,comp-verbose + (setf comp-verbose ,comp-verbose comp-ctxt ,comp-ctxt comp-eln-load-path ',comp-eln-load-path comp-native-driver-options @@ -2988,6 +2996,7 @@ load once finished compiling." (list "Not a function symbol or file" function-or-file))) (let* ((data function-or-file) (comp-native-compiling t) + (byte-native-qualities nil) ;; Have byte compiler signal an error when compilation fails. (byte-compile-debug t) (comp-ctxt (make-comp-ctxt :output output diff --git a/src/comp.c b/src/comp.c index 48e4f1c8cd..05ec073c1f 100644 --- a/src/comp.c +++ b/src/comp.c @@ -423,10 +423,6 @@ load_gccjit_if_necessary (bool mandatory) #define TEXT_OPTIM_QLY_SYM "text_optim_qly" #define TEXT_FDOC_SYM "text_data_fdoc" - -#define COMP_SPEED XFIXNUM (Fsymbol_value (Qcomp_speed)) -#define COMP_DEBUG XFIXNUM (Fsymbol_value (Qcomp_debug)) - #define STR_VALUE(s) #s #define STR(s) STR_VALUE (s) @@ -485,6 +481,8 @@ enum cast_kind_of_type /* C side of the compiler context. */ typedef struct { + EMACS_INT speed; + EMACS_INT debug; gcc_jit_context *ctxt; gcc_jit_type *void_type; gcc_jit_type *bool_type; @@ -916,7 +914,7 @@ obj_to_reloc (Lisp_Object obj) static void emit_comment (const char *str) { - if (COMP_DEBUG) + if (comp.debug) gcc_jit_block_add_comment (comp.block, NULL, str); @@ -1847,7 +1845,7 @@ emit_mvar_rval (Lisp_Object mvar) if (!NILP (const_vld)) { - if (COMP_DEBUG > 1) + if (comp.debug > 1) { Lisp_Object func = Fgethash (constant, @@ -2566,7 +2564,7 @@ emit_static_object (const char *name, Lisp_Object obj) 0, NULL, 0); DECL_BLOCK (block, f); - if (COMP_DEBUG > 1) + if (comp.debug > 1) { char *comment = memcpy (xmalloc (len), p, len); for (ptrdiff_t i = 0; i < len - 1; i++) @@ -2789,10 +2787,8 @@ emit_ctxt_code (void) { /* Emit optimize qualities. */ Lisp_Object opt_qly[] = - { Fcons (Qcomp_speed, - Fsymbol_value (Qcomp_speed)), - Fcons (Qcomp_debug, - Fsymbol_value (Qcomp_debug)), + { Fcons (Qcomp_speed, make_fixnum (comp.speed)), + Fcons (Qcomp_debug, make_fixnum (comp.debug)), Fcons (Qgccjit, Fcomp_libgccjit_version ()) }; emit_static_object (TEXT_OPTIM_QLY_SYM, Flist (ARRAYELTS (opt_qly), opt_qly)); @@ -4212,13 +4208,13 @@ DEFUN ("comp--init-ctxt", Fcomp__init_ctxt, Scomp__init_ctxt, comp.ctxt = gcc_jit_context_acquire (); - if (COMP_DEBUG) + if (comp.debug) { gcc_jit_context_set_bool_option (comp.ctxt, GCC_JIT_BOOL_OPTION_DEBUGINFO, 1); } - if (COMP_DEBUG > 2) + if (comp.debug > 2) { logfile = fopen ("libgccjit.log", "w"); gcc_jit_context_set_logfile (comp.ctxt, @@ -4403,10 +4399,12 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, CHECK_STRING (filename); Lisp_Object base_name = Fsubstring (filename, Qnil, make_fixnum (-4)); + comp.speed = XFIXNUM (CALL1I (comp-ctxt-speed, Vcomp_ctxt)); + comp.debug = XFIXNUM (CALL1I (comp-ctxt-debug, Vcomp_ctxt)); gcc_jit_context_set_int_option (comp.ctxt, GCC_JIT_INT_OPTION_OPTIMIZATION_LEVEL, - COMP_SPEED < 0 ? 0 - : (COMP_SPEED > 3 ? 3 : COMP_SPEED)); + comp.speed < 0 ? 0 + : (comp.speed > 3 ? 3 : comp.speed)); comp.d_default_idx = CALL1I (comp-data-container-idx, CALL1I (comp-ctxt-d-default, Vcomp_ctxt)); comp.d_impure_idx = @@ -4456,11 +4454,11 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, add_driver_options (); - if (COMP_DEBUG) + if (comp.debug) gcc_jit_context_dump_to_file (comp.ctxt, format_string ("%s.c", SSDATA (base_name)), 1); - if (COMP_DEBUG > 2) + if (comp.debug > 2) gcc_jit_context_dump_reproducer_to_file (comp.ctxt, "comp_reproducer.c"); Lisp_Object tmp_file = commit acf101c63644da5587822afbea1b186d91ff3348 Author: Andrea Corallo Date: Fri Nov 6 22:22:48 2020 +0100 Handle type hierarchy in native compiler forward propagation 2020-11-07 Andrea Corallo * lisp/emacs-lisp/cl-preloaded.el (cl--typeof-types): Add fixnum and bignum. * lisp/emacs-lisp/comp.el (comp-ctxt): Add `supertype-memoize' slot. (comp-supertypes, comp-common-supertype-2) (comp-common-supertype): New functions. (comp-fwprop-insn): Make use of `comp-common-supertype' to identify the common supertype to be propagated. diff --git a/lisp/emacs-lisp/cl-preloaded.el b/lisp/emacs-lisp/cl-preloaded.el index eed43c5ed3..b5dbcbda47 100644 --- a/lisp/emacs-lisp/cl-preloaded.el +++ b/lisp/emacs-lisp/cl-preloaded.el @@ -52,7 +52,8 @@ (defconst cl--typeof-types ;; Hand made from the source code of `type-of'. - '((integer number number-or-marker atom) + '((fixnum integer number number-or-marker atom) + (bignum integer number number-or-marker atom) (symbol atom) (string array sequence atom) (cons list sequence) ;; Markers aren't `numberp', yet they are accepted wherever integers are diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 51fed2ffd3..bb32aefcad 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -278,7 +278,10 @@ This is tipically for top-level forms other than defun.") (d-ephemeral (make-comp-data-container) :type comp-data-container :documentation "Relocated data not necessary after load.") (with-late-load nil :type boolean - :documentation "When non-nil support late load.")) + :documentation "When non-nil support late load.") + (supertype-memoize (make-hash-table :test #'equal) :type hash-table + :documentation "Serve memoization for + `comp-common-supertype'.")) (cl-defstruct comp-args-base (min nil :type number @@ -2124,6 +2127,40 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non-nil." 'fixnum (type-of obj))) +(defun comp-supertypes (type) + "Return a list of pairs (supertype . hierarchy-level) for TYPE." + (cl-loop + named outer + with found = nil + for l in cl--typeof-types + do (cl-loop + for x in l + for i from (length l) downto 0 + when (eq type x) + do (setf found t) + when found + collect `(,x . ,i) into res + finally (when found + (cl-return-from outer res))))) + +(defun comp-common-supertype-2 (type1 type2) + "Return the first common supertype of TYPE1 TYPE2." + (car (cl-reduce (lambda (x y) + (if (> (cdr x) (cdr y)) + x + y)) + (cl-intersection + (comp-supertypes type1) + (comp-supertypes type2) + :key #'car)))) + +(defun comp-common-supertype (&rest types) + "Return the first common supertype of TYPES." + (or (gethash types (comp-ctxt-supertype-memoize comp-ctxt)) + (puthash types + (cl-reduce #'comp-common-supertype-2 types) + (comp-ctxt-supertype-memoize comp-ctxt)))) + (defun comp-copy-insn (insn) "Deep copy INSN." ;; Adapted from `copy-tree'. @@ -2252,12 +2289,9 @@ Forward propagate immediate involed in assignments." (setf (comp-mvar-const-vld lval) t (comp-mvar-constant lval) x)) ;; Forward type propagation. - ;; FIXME: checking for type equality is not sufficient cause does not - ;; account type hierarchy! (when-let* ((types (mapcar #'comp-mvar-type rest)) (non-empty (cl-notany #'null types)) - (x (car types)) - (eqs (cl-every (lambda (y) (eq x y)) types))) + (x (comp-common-supertype types))) (setf (comp-mvar-type lval) x))))) (defun comp-fwprop* () commit c6abe97f941a5021d416e01fb0f61a675c5f6b29 Author: Andrea Corallo Date: Thu Nov 5 22:23:48 2020 +0100 * A native compiler forward propagation fix * lisp/emacs-lisp/comp.el (comp-fwprop-insn): Fix `comp-mvar' `const-vld' slot left unset while propagating in phis. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index b35fe9bfcb..51fed2ffd3 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2249,7 +2249,8 @@ Forward propagate immediate involed in assignments." (consts (mapcar #'comp-mvar-constant rest)) (x (car consts)) (equals (cl-every (lambda (y) (equal x y)) consts))) - (setf (comp-mvar-constant lval) x)) + (setf (comp-mvar-const-vld lval) t + (comp-mvar-constant lval) x)) ;; Forward type propagation. ;; FIXME: checking for type equality is not sufficient cause does not ;; account type hierarchy! commit 3e3843512bfae0b7a532f633e45d4c140807ec9b Author: Andrea Corallo Date: Sun Nov 1 13:58:06 2020 +0100 * Fix 'comp-call-optim pass' for anonymous lambdas * lisp/emacs-lisp/comp.el (comp-call-optim-func): Remove anonymous lambdas gate. (comp-call-optim-form-call): Add the correct missing condition. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 9b26f6c419..b35fe9bfcb 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2346,6 +2346,7 @@ FUNCTION can be a function-name or byte compiled function." ;; Intra compilation unit procedure call optimization. ;; Attention speed 3 triggers this for non self calls too!! ((and comp-func-callee + (comp-func-c-name comp-func-callee) (or (and (>= (comp-func-speed comp-func) 3) (comp-func-unique-in-cu-p callee)) (and (>= (comp-func-speed comp-func) 2) @@ -2365,9 +2366,7 @@ FUNCTION can be a function-name or byte compiled function." (defun comp-call-optim-func () "Perform the trampoline call optimization for the current function." (cl-loop - with self = (comp-func-name comp-func) for b being each hash-value of (comp-func-blocks comp-func) - when self ;; FIXME add proper anonymous lambda support. do (comp-loop-insn-in-block b (pcase insn (`(set ,lval (callref funcall ,f . ,rest)) commit 933fd76f8fa4583aa3c4cc6e6e22f9a96638c5a5 Author: Andrea Corallo Date: Sun Nov 1 14:41:17 2020 +0100 * test/src/comp-tests.el (compile-forms): Fix missing lexical binding. diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 9c3c7f62a3..21c8abad03 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -418,7 +418,8 @@ https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-03/msg00914.html." (comp-deftest compile-forms () "Verify lambda form native compilation." (should-error (native-compile '(+ 1 foo))) - (let ((f (native-compile '(lambda (x) (1+ x))))) + (let ((lexical-binding t) + (f (native-compile '(lambda (x) (1+ x))))) (should (subr-native-elisp-p f)) (should (= (funcall f 2) 3))) (let* ((lexical-binding nil) commit e1a168f9a73cfb5a70d3f313e62dd1eaab14e214 Author: Andrea Corallo Date: Sun Nov 1 14:37:13 2020 +0100 * Add some 'cond-rw' pass related tests * test/src/comp-tests.el (comp-tests-cond-rw-checked-function): Declare var. (comp-tests-cond-rw-checker-val): New function. (comp-tests-cond-rw-checker-type): Declare var. (comp-tests-cond-rw-checker-type): New function. (comp-tests-cond-rw-0-var): Declare var. (comp-tests-cond-rw-0, comp-tests-cond-rw-1, comp-tests-cond-rw-2) (comp-tests-cond-rw-3, comp-tests-cond-rw-4) (comp-tests-cond-rw-5): New testcases. diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 4834e21fba..9c3c7f62a3 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -791,4 +791,95 @@ Return a list of results." (should (subr-native-elisp-p (symbol-function #'comp-tests-pure-fibn-entry-f))) (should (= (comp-tests-pure-fibn-entry-f) 6765)))) +(defvar comp-tests-cond-rw-checked-function nil + "Function to be checked.") +(defun comp-tests-cond-rw-checker-val (_) + "Check we manage to propagate the correct return value." + (should + (cl-some + #'identity + (comp-tests-map-checker + comp-tests-cond-rw-checked-function + (lambda (insn) + (pcase insn + (`(return ,mvar) + (and (comp-mvar-const-vld mvar) + (= (comp-mvar-constant mvar) 123))))))))) + +(defvar comp-tests-cond-rw-expected-type nil + "Type to expect in `comp-tests-cond-rw-checker-type'.") +(defun comp-tests-cond-rw-checker-type (_) + "Check we manage to propagate the correct return type." + (should + (cl-some + #'identity + (comp-tests-map-checker + comp-tests-cond-rw-checked-function + (lambda (insn) + (pcase insn + (`(return ,mvar) + (eq (comp-mvar-type mvar) comp-tests-cond-rw-expected-type)))))))) + +(defvar comp-tests-cond-rw-0-var) +(comp-deftest cond-rw-0 () + "Check we do not miscompile some simple functions." + (let ((lexical-binding t)) + (let ((f (native-compile '(lambda (l) + (when (eq (car l) 'x) + (cdr l)))))) + (should (subr-native-elisp-p f)) + (should (eq (funcall f '(x . y)) 'y)) + (should (null (funcall f '(z . y))))) + + (should + (subr-native-elisp-p + (native-compile '(lambda () (if (eq comp-tests-cond-rw-0-var 123) 5 10))))))) + +(comp-deftest cond-rw-1 () + "Test cond-rw pass allow us to propagate type+val under `eq' tests." + (let ((lexical-binding t) + (comp-tests-cond-rw-expected-type 'fixnum) + (comp-post-pass-hooks '((comp-final comp-tests-cond-rw-checker-type) + (comp-final comp-tests-cond-rw-checker-val)))) + (subr-native-elisp-p (native-compile '(lambda (x) (if (eq x 123) x t)))) + (subr-native-elisp-p (native-compile '(lambda (x) (if (eq 123 x) x t)))))) + +(comp-deftest cond-rw-2 () + "Test cond-rw pass allow us to propagate type+val under `=' tests." + (let ((lexical-binding t) + (comp-tests-cond-rw-expected-type 'fixnum) + (comp-post-pass-hooks '((comp-final comp-tests-cond-rw-checker-type) + (comp-final comp-tests-cond-rw-checker-val)))) + (subr-native-elisp-p (native-compile '(lambda (x) (if (= x 123) x t)))))) + +(comp-deftest cond-rw-3 () + "Test cond-rw pass allow us to propagate type+val under `eql' tests." + (let ((lexical-binding t) + (comp-tests-cond-rw-expected-type 'fixnum) + (comp-post-pass-hooks '((comp-final comp-tests-cond-rw-checker-type) + (comp-final comp-tests-cond-rw-checker-val)))) + (subr-native-elisp-p (native-compile '(lambda (x) (if (eql 123 x) x t)))))) + +(comp-deftest cond-rw-4 () + "Test cond-rw pass allow us to propagate type under `=' tests." + (let ((lexical-binding t) + (comp-tests-cond-rw-expected-type 'number) + (comp-post-pass-hooks '((comp-final comp-tests-cond-rw-checker-type)))) + (subr-native-elisp-p (native-compile '(lambda (x y) (if (= x y) x t)))))) + +(comp-deftest cond-rw-5 () + "Test cond-rw pass allow us to propagate type under `=' tests." + (let ((lexical-binding t) + (comp-tests-cond-rw-checked-function #'comp-tests-cond-rw-4-f) + (comp-tests-cond-rw-expected-type 'fixnum) + (comp-post-pass-hooks '((comp-final comp-tests-cond-rw-checker-type)))) + (eval '(defun comp-tests-cond-rw-4-f (x y) + (declare (speed 3)) + (if (= x (comp-hint-fixnum y)) + x + t)) + t) + (native-compile #'comp-tests-cond-rw-4-f) + (should (subr-native-elisp-p (symbol-function #'comp-tests-cond-rw-4-f))))) + ;;; comp-tests.el ends here commit 42970cceb9b15212f1a2a28a4595efc8c960f929 Author: Andrea Corallo Date: Tue Oct 27 19:40:55 2020 +0000 Add new cond-rw pass to have forward propagation track cond branches Add a new pass to rewrite conditional branches. This is introducing and placing a new LIMPLE operator 'assume' in use by fwprop to propagate conditional branch test informations on target basic blocks. * lisp/emacs-lisp/comp.el (comp-passes): Add `comp-cond-rw'. (comp-limple-assignments): Add `assume' operator. (comp-emit-assume, comp-cond-rw-target-slot, comp-cond-rw-func) (comp-cond-rw): Add new functions. (comp-fwprop-insn): Update to pattern match `assume' insns. * src/comp.c (emit_limple_insn): Add for `assume'. (syms_of_comp): Define 'Qassume' symbol. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 15b8b3ab8d..9b26f6c419 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -171,6 +171,7 @@ Can be one of: 'd-default', 'd-impure' or 'd-ephemeral'. See `comp-ctxt'.") comp-fwprop comp-call-optim comp-ipa-pure + comp-cond-rw comp-fwprop comp-dead-code comp-tco @@ -216,7 +217,8 @@ Useful to hook into pass checkers.") set-rest-args-to-local) "Limple set operators.") -(defconst comp-limple-assignments `(fetch-handler +(defconst comp-limple-assignments `(assume + fetch-handler ,@comp-limple-sets) "Limple operators that clobbers the first m-var argument.") @@ -1676,6 +1678,73 @@ into the C code forwarding the compilation unit." (when (comp-ctxt-with-late-load comp-ctxt) (comp-add-func-to-ctxt (comp-limplify-top-level t)))) + +;;; conditional branches rewrite pass specific code. + +(defun comp-emit-assume (target-slot rhs bb-name kind) + "Emit an assume of kind KIND for TARGET-SLOT being RHS. +The assume is emitted at the beginning of the block named +BB-NAME." + (push `(assume ,(make-comp-mvar :slot target-slot) ,rhs ,kind) + (comp-block-insns (gethash bb-name (comp-func-blocks comp-func)))) + (setf (comp-func-ssa-status comp-func) 'dirty)) + +(defun comp-cond-rw-target-slot (slot-num exit-insn bb) + "Search for the last assignment of SLOT-NUM in BB. +Keep on searching till EXIT-INSN is encountered. +Return the corresponding rhs slot number." + (cl-flet ((targetp (x) + ;; Ret t if x is an mvar and target the correct slot number. + (and (comp-mvar-p x) + (eql slot-num (comp-mvar-slot x))))) + (cl-loop + with res = nil + for insn in (comp-block-insns bb) + when (eq insn exit-insn) + do (cl-return (and (comp-mvar-p res) (comp-mvar-slot res))) + do (pcase insn + (`(,(pred comp-assign-op-p) ,(pred targetp) ,rhs) + (setf res rhs))) + finally (cl-assert nil)))) + +(defun comp-cond-rw-func () + "`comp-cond-rw' worker function for each selected function." + (cl-loop + for b being each hash-value of (comp-func-blocks comp-func) + do (cl-loop + named in-the-basic-block + for insns-seq on (comp-block-insns b) + do (pcase insns-seq + (`((set ,(and (pred comp-mvar-p) cond) + (,(pred comp-call-op-p) + ,(and (or 'eq 'eql '= 'equal) test-fn) ,op1 ,op2)) + (comment ,_comment-str) + (cond-jump ,cond ,(pred comp-mvar-p) ,bb-1 ,_bb-2)) + (when-let ((target-slot1 (comp-cond-rw-target-slot + (comp-mvar-slot op1) (car insns-seq) b))) + (comp-emit-assume target-slot1 op2 bb-1 test-fn)) + (when-let ((target-slot2 (comp-cond-rw-target-slot + (comp-mvar-slot op2) (car insns-seq) b))) + (comp-emit-assume target-slot2 op1 bb-1 test-fn)) + (cl-return-from in-the-basic-block)))))) + +(defun comp-cond-rw (_) + "Rewrite conditional branches adding appropriate 'assume' insns. +This is introducing and placing 'assume' insns in use by fwprop +to propagate conditional branch test informations on target basic +blocks." + (maphash (lambda (_ f) + (when (and (>= (comp-func-speed f) 1) + ;; No point to run this on dynamic scope as + ;; this pass is effecive only on local + ;; variables. + (comp-func-l-p f) + (not (comp-func-has-non-local f))) + (let ((comp-func f)) + (comp-cond-rw-func) + (comp-log-func comp-func 3)))) + (comp-ctxt-funcs-h comp-ctxt))) + ;;; pure-func pass specific code. @@ -2158,6 +2227,18 @@ Forward propagate immediate involed in assignments." (comp-function-call-maybe-remove insn f args))) (_ (comp-mvar-propagate lval rval)))) + (`(assume ,lval ,rval ,kind) + (pcase kind + ('eq + (comp-mvar-propagate lval rval)) + ((or 'eql 'equal) + (if (memq (comp-mvar-type rval) '(symbol fixnum)) + (comp-mvar-propagate lval rval) + (setf (comp-mvar-type lval) (comp-mvar-type rval)))) + ('= + (if (eq (comp-mvar-type rval) 'fixnum) + (comp-mvar-propagate lval rval) + (setf (comp-mvar-type lval) 'number))))) (`(setimm ,lval ,v) (setf (comp-mvar-const-vld lval) t (comp-mvar-constant lval) v diff --git a/src/comp.c b/src/comp.c index 0c555578f8..48e4f1c8cd 100644 --- a/src/comp.c +++ b/src/comp.c @@ -2131,9 +2131,9 @@ emit_limple_insn (Lisp_Object insn) n); emit_cond_jump (test, target2, target1); } - else if (EQ (op, Qphi)) + else if (EQ (op, Qphi) || EQ (op, Qassume)) { - /* Nothing to do for phis into the backend. */ + /* Nothing to do for phis or assumes in the backend. */ } else if (EQ (op, Qpush_handler)) { @@ -5134,6 +5134,7 @@ native compiled one. */); DEFSYM (Qcallref, "callref"); DEFSYM (Qdirect_call, "direct-call"); DEFSYM (Qdirect_callref, "direct-callref"); + DEFSYM (Qassume, "assume"); DEFSYM (Qsetimm, "setimm"); DEFSYM (Qreturn, "return"); DEFSYM (Qcomp_mvar, "comp-mvar"); commit 047fe3292d2f102c9aed4dc305de165b627bcddd Author: Andrea Corallo Date: Sun Nov 1 09:57:06 2020 +0100 * Rework some native compiler test infrastructure * test/src/comp-tests.el (comp-tests-map-checker): New function returning a list holding checker results. (comp-tests-tco-checker, comp-tests-fw-prop-checker-1) (comp-tests-pure-checker-1, comp-tests-pure-checker-2): Make use of `comp-tests-map-checker'. diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 446a61549d..4834e21fba 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -686,28 +686,29 @@ https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-03/msg00914.html." 'comment) (comp-tests-mentioned-p-1 x insn))) -(defun comp-tests-make-insn-checker (func-name checker) - "Apply CHECKER to each insn in FUNC-NAME. -CHECKER should always return nil to have a pass." - (should-not - (cl-loop - named checker-loop - with func-c-name = (comp-c-func-name func-name "F" t) +(defun comp-tests-map-checker (func-name checker) + "Apply CHECKER to each insn of FUNC-NAME. +Return a list of results." + (cl-loop + with func-c-name = (comp-c-func-name (or func-name 'anonymous-lambda) "F" t) with f = (gethash func-c-name (comp-ctxt-funcs-h comp-ctxt)) for bb being each hash-value of (comp-func-blocks f) - do (cl-loop - for insn in (comp-block-insns bb) - when (funcall checker insn) - do (cl-return-from checker-loop 'mentioned))))) + nconc + (cl-loop + for insn in (comp-block-insns bb) + collect (funcall checker insn)))) (defun comp-tests-tco-checker (_) "Check that inside `comp-tests-tco-f' we have no recursion." - (comp-tests-make-insn-checker - 'comp-tests-tco-f - (lambda (insn) - (or (comp-tests-mentioned-p 'comp-tests-tco-f insn) - (comp-tests-mentioned-p (comp-c-func-name 'comp-tests-tco-f "F" t) - insn))))) + (should + (cl-notany + #'identity + (comp-tests-map-checker + 'comp-tests-tco-f + (lambda (insn) + (or (comp-tests-mentioned-p 'comp-tests-tco-f insn) + (comp-tests-mentioned-p (comp-c-func-name 'comp-tests-tco-f "F" t) + insn))))))) (comp-deftest tco () "Check for tail recursion elimination." @@ -728,11 +729,14 @@ CHECKER should always return nil to have a pass." (defun comp-tests-fw-prop-checker-1 (_) "Check that inside `comp-tests-fw-prop-f' `concat' and `length' are folded." - (comp-tests-make-insn-checker - 'comp-tests-fw-prop-1-f - (lambda (insn) - (or (comp-tests-mentioned-p 'concat insn) - (comp-tests-mentioned-p 'length insn))))) + (should + (cl-notany + #'identity + (comp-tests-map-checker + 'comp-tests-fw-prop-1-f + (lambda (insn) + (or (comp-tests-mentioned-p 'concat insn) + (comp-tests-mentioned-p 'length insn))))))) (comp-deftest fw-prop () "Some tests for forward propagation." @@ -751,21 +755,28 @@ CHECKER should always return nil to have a pass." (defun comp-tests-pure-checker-1 (_) "Check that inside `comp-tests-pure-caller-f' `comp-tests-pure-callee-f' is folded." - (comp-tests-make-insn-checker - 'comp-tests-pure-caller-f - (lambda (insn) - (or (comp-tests-mentioned-p 'comp-tests-pure-callee-f insn) - (comp-tests-mentioned-p (comp-c-func-name 'comp-tests-pure-callee-f "F" t) - insn))))) + (should + (cl-notany + #'identity + (comp-tests-map-checker + 'comp-tests-pure-caller-f + (lambda (insn) + (or (comp-tests-mentioned-p 'comp-tests-pure-callee-f insn) + (comp-tests-mentioned-p (comp-c-func-name + 'comp-tests-pure-callee-f "F" t) + insn))))))) (defun comp-tests-pure-checker-2 (_) "Check that `comp-tests-pure-fibn-f' is folded." - (comp-tests-make-insn-checker - 'comp-tests-pure-fibn-entry-f - (lambda (insn) - (or (comp-tests-mentioned-p 'comp-tests-pure-fibn-f insn) - (comp-tests-mentioned-p (comp-c-func-name 'comp-tests-pure-fibn-f "F" t) - insn))))) + (should + (cl-notany + #'identity + (comp-tests-map-checker + 'comp-tests-pure-fibn-entry-f + (lambda (insn) + (or (comp-tests-mentioned-p 'comp-tests-pure-fibn-f insn) + (comp-tests-mentioned-p (comp-c-func-name 'comp-tests-pure-fibn-f "F" t) + insn))))))) (comp-deftest pure () "Some tests for pure functions optimization." commit f7f5d59ab4c4cc1a7db46d7f1d462655254e1a87 Merge: fd9e9308d2 283b8d274b Author: Andrea Corallo Date: Sat Oct 31 15:00:00 2020 +0000 Merge remote-tracking branch 'savannah/master' into HEAD commit fd9e9308d27138a16e2e93417bd7ad4448fea40a Author: Andrea Corallo Date: Mon Oct 26 16:31:13 2020 +0000 Make native compiler tollerant to redefined primitives (bug#44221). * lisp/emacs-lisp/comp.el (comp-emit-set-call-subr): Rework based on the fact that the subr can now be redefined. * test/src/comp-tests.el (primitive-redefine-compile-44221): New testcase. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 1808e727bb..15b8b3ab8d 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1153,9 +1153,7 @@ Return value is the fall through block name." SP-DELTA is the stack adjustment." (let ((subr (symbol-function subr-name)) (nargs (1+ (- sp-delta)))) - (unless (subrp subr) - (signal 'native-ice (list "not a subr" subr))) - (let* ((arity (subr-arity subr)) + (let* ((arity (func-arity subr)) (minarg (car arity)) (maxarg (cdr arity))) (when (eq maxarg 'unevalled) diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index ae96e5d386..446a61549d 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -430,6 +430,15 @@ https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-03/msg00914.html." ;; Bug#42664, Bug#43280, Bug#44209. (should-not (subr-native-elisp-p (symbol-function #'comp-test-defsubst-f)))) +(comp-deftest primitive-redefine-compile-44221 () + "Test the compiler still works while primitives are redefined (bug#44221)." + (cl-letf (((symbol-function #'delete-region) + (lambda (_ _)))) + (should (subr-native-elisp-p + (native-compile + '(lambda () + (delete-region (point-min) (point-max)))))))) + ;;;;;;;;;;;;;;;;;;;;; ;; Tromey's tests. ;; commit 5edc7aa0193ec73f757e85012273c159301f64a9 Author: Andrea Corallo Date: Sun Oct 25 21:19:25 2020 +0000 Fix defsubst effectiveness (bug#44209) * lisp/emacs-lisp/byte-run.el (defsubst): Fix macro definition. * test/src/comp-tests.el (comp-test-defsubst): New testcase. * test/src/comp-test-funcs.el (comp-test-defsubst-f): New function. diff --git a/lisp/emacs-lisp/byte-run.el b/lisp/emacs-lisp/byte-run.el index 042a26a2e3..1bc7839188 100644 --- a/lisp/emacs-lisp/byte-run.el +++ b/lisp/emacs-lisp/byte-run.el @@ -363,13 +363,13 @@ You don't need this. (See bytecomp.el commentary for more details.) (or (memq (get name 'byte-optimizer) '(nil byte-compile-inline-expand)) (error "`%s' is a primitive" name)) - ;; Never native-compile defsubsts as we need the byte - ;; definition in `byte-compile-unfold-bcf' to perform the - ;; inlining (Bug#42664). - (byte-run--set-speed name nil -1) `(prog1 (defun ,name ,arglist ,@body) (eval-and-compile + ;; Never native-compile defsubsts as we need the byte + ;; definition in `byte-compile-unfold-bcf' to perform the + ;; inlining (Bug#42664, Bug#43280, Bug#44209). + ,(byte-run--set-speed name nil -1) (put ',name 'byte-optimizer 'byte-compile-inline-expand)))) (defvar advertised-signature-table (make-hash-table :test 'eq :weakness 'key)) diff --git a/test/src/comp-test-funcs.el b/test/src/comp-test-funcs.el index 9285ed62c2..35df46a9b8 100644 --- a/test/src/comp-test-funcs.el +++ b/test/src/comp-test-funcs.el @@ -345,6 +345,9 @@ (declare (speed 2)) (- x y)) +(defsubst comp-test-defsubst-f () + t) + ;;;;;;;;;;;;;;;;;;;; ;; Tromey's tests ;; diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index b9a0a8771e..ae96e5d386 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -426,6 +426,10 @@ https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-03/msg00914.html." (should (subr-native-elisp-p f)) (should (= (funcall f 2) 3)))) +(comp-deftest comp-test-defsubst () + ;; Bug#42664, Bug#43280, Bug#44209. + (should-not (subr-native-elisp-p (symbol-function #'comp-test-defsubst-f)))) + ;;;;;;;;;;;;;;;;;;;;; ;; Tromey's tests. ;; commit 096c78523d849a75847152dff7458e883d668cb8 Author: Andrea Corallo Date: Sun Oct 25 19:31:39 2020 +0000 * Fix a function for native compilation in cc-bytecomp.el * lisp/progmodes/cc-bytecomp.el (cc-bytecomp-compiling-or-loading): Update for native compilation. diff --git a/lisp/progmodes/cc-bytecomp.el b/lisp/progmodes/cc-bytecomp.el index ad884288a6..7798b49f39 100644 --- a/lisp/progmodes/cc-bytecomp.el +++ b/lisp/progmodes/cc-bytecomp.el @@ -110,14 +110,15 @@ (memq (cadr elt) '(load require byte-compile-file byte-recompile-directory - batch-byte-compile))))) + batch-byte-compile batch-native-compile))))) (setq n (1+ n))) (cond ((memq (cadr elt) '(load require)) 'loading) ((memq (cadr elt) '(byte-compile-file byte-recompile-directory - batch-byte-compile)) + batch-byte-compile + batch-native-compile)) 'compiling) (t ; Can't happen. (message "cc-bytecomp-compiling-or-loading: System flags spuriously set") commit ac143165ccf31f4c0b18947e92cb6cb18ae67323 Author: Andrea Corallo Date: Sun Oct 25 15:45:27 2020 +0000 * Fix ELC+ELN vs ELC prefix while building non AoT native compiled files * lisp/Makefile.in (am__v_ELC_0): Set it correctly when NATIVE_DISABLED is 1. diff --git a/lisp/Makefile.in b/lisp/Makefile.in index 91873086d2..d6bb4cf557 100644 --- a/lisp/Makefile.in +++ b/lisp/Makefile.in @@ -37,7 +37,11 @@ HAVE_NATIVE_COMP = @HAVE_NATIVE_COMP@ AM_V_ELC = $(am__v_ELC_@AM_V@) am__v_ELC_ = $(am__v_ELC_@AM_DEFAULT_V@) ifeq ($(HAVE_NATIVE_COMP),yes) +ifeq ($(NATIVE_DISABLED),1) +am__v_ELC_0 = @echo " ELC " $@; +else am__v_ELC_0 = @echo " ELC+ELN " $@; +endif ifndef NATIVE_FULL_AOT NATIVE_SKIP_NONDUMP = 1 endif commit 868d3ff9b87ce85014870c9688b899e640866b48 Author: Andrea Corallo Date: Fri Oct 23 10:26:31 2020 +0200 * Report warnings and errors from native asynchronous compilation (bug#44168) * lisp/emacs-lisp/comp.el (comp-last-scanned-async-output): New buffer local variable. (comp-accept-and-process-async-output): New function. (comp-run-async-workers): Use `comp-accept-and-process-async-output'. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index a13b974b94..1808e727bb 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -128,6 +128,11 @@ before compilation. Usable to modify the compiler environment." :type 'list :group 'comp) +(defcustom comp-async-report-warnings-errors t + "Report warnings and errors from native asynchronous compilation." + :type 'boolean + :group 'comp) + (defcustom comp-native-driver-options nil "Options passed verbatim to the native compiler's backend driver. Note that not all options are meaningful; typically only the options @@ -2768,6 +2773,21 @@ processes from `comp-async-compilations'" 2)))) comp-async-jobs-number)) +(defvar comp-last-scanned-async-output nil) +(make-variable-buffer-local 'comp-last-scanned-async-output) +(defun comp-accept-and-process-async-output (process) + "Accept PROCESS output and check for diagnostic messages." + (if comp-async-report-warnings-errors + (with-current-buffer (process-buffer process) + (save-excursion + (accept-process-output process) + (goto-char (or comp-last-scanned-async-output (point-min))) + (while (re-search-forward "^.*+?\\(?:Error\\|Warning\\): .*$" + nil t) + (display-warning 'comp (match-string 0))) + (setq comp-last-scanned-async-output (point-max)))) + (accept-process-output process))) + (defun comp-run-async-workers () "Start compiling files from `comp-files-queue' asynchronously. When compilation is finished, run `comp-async-all-done-hook' and @@ -2822,7 +2842,7 @@ display a message." (run-hook-with-args 'comp-async-cu-done-hook source-file) - (accept-process-output process) + (comp-accept-and-process-async-output process) (ignore-errors (delete-file temp-file)) (when (and load1 (zerop (process-exit-status process))) commit ada80d66d663ac9e07082f6038528f004f9aca1f Author: Andrea Corallo Date: Sun Oct 25 09:41:56 2020 +0000 * Fix `comp-dry-run' effectiveness * lisp/emacs-lisp/comp.el (comp-compile-ctxt-to-file): Remove `comp-dry-run' guard. (comp-final): And move it here so is effective for interactive sessions and non. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 4967e8558b..a13b974b94 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2526,8 +2526,7 @@ Prepare every function for final compilation and drive the C back-end." ;; In case it's created in the meanwhile. (ignore-error 'file-already-exists (make-directory dir t))) - (unless comp-dry-run - (comp--compile-ctxt-to-file name)))) + (comp--compile-ctxt-to-file name))) (defun comp-final1 () (let (compile-result) @@ -2540,44 +2539,45 @@ Prepare every function for final compilation and drive the C back-end." (defun comp-final (_) "Final pass driving the C back-end for code emission." - (if noninteractive - (comp-final1) - ;; Call comp-final1 in a child process. - (let* ((output (comp-ctxt-output comp-ctxt)) - (print-escape-newlines t) - (print-length nil) - (print-level nil) - (print-quoted t) - (print-gensym t) - (print-circle t) - (expr `(progn - (require 'comp) - (setf comp-speed ,comp-speed - comp-debug ,comp-debug - comp-verbose ,comp-verbose - comp-ctxt ,comp-ctxt - comp-eln-load-path ',comp-eln-load-path - comp-native-driver-options - ',comp-native-driver-options - load-path ',load-path) - ,comp-async-env-modifier-form - (message "Compiling %s..." ',output) - (comp-final1))) - (temp-file (make-temp-file - (concat "emacs-int-comp-" - (file-name-base output) "-") - nil ".el"))) - (with-temp-file temp-file - (insert (prin1-to-string expr))) - (with-temp-buffer - (unwind-protect - (if (zerop - (call-process (expand-file-name invocation-name - invocation-directory) - nil t t "--batch" "-l" temp-file)) - output - (signal 'native-compiler-error (buffer-string))) - (comp-log-to-buffer (buffer-string))))))) + (unless comp-dry-run + (if noninteractive + (comp-final1) + ;; Call comp-final1 in a child process. + (let* ((output (comp-ctxt-output comp-ctxt)) + (print-escape-newlines t) + (print-length nil) + (print-level nil) + (print-quoted t) + (print-gensym t) + (print-circle t) + (expr `(progn + (require 'comp) + (setf comp-speed ,comp-speed + comp-debug ,comp-debug + comp-verbose ,comp-verbose + comp-ctxt ,comp-ctxt + comp-eln-load-path ',comp-eln-load-path + comp-native-driver-options + ',comp-native-driver-options + load-path ',load-path) + ,comp-async-env-modifier-form + (message "Compiling %s..." ',output) + (comp-final1))) + (temp-file (make-temp-file + (concat "emacs-int-comp-" + (file-name-base output) "-") + nil ".el"))) + (with-temp-file temp-file + (insert (prin1-to-string expr))) + (with-temp-buffer + (unwind-protect + (if (zerop + (call-process (expand-file-name invocation-name + invocation-directory) + nil t t "--batch" "-l" temp-file)) + output + (signal 'native-compiler-error (buffer-string))) + (comp-log-to-buffer (buffer-string)))))))) ;;; Compiler type hints. commit 99e7cc0da652bf0f19f691d5de3b3ce7c15e8c39 Merge: 3be93390fb 46f5d2867c Author: Andrea Corallo Date: Fri Oct 23 20:08:58 2020 +0100 Merge remote-tracking branch 'savannah/master' into HEAD commit 3be93390fb6680d1e0c3256af72c86635a9eb327 Author: Andrea Corallo Date: Tue Oct 20 20:55:11 2020 +0100 Sanitize eln filename when native compiling single functions * lisp/emacs-lisp/comp.el (comp-spill-lap-function): Fix temporary eln name generation. * test/src/comp-tests.el (free-fun-silly-name): New testcase. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 6c54085750..4967e8558b 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -664,7 +664,8 @@ clashes." "Byte-compile FUNCTION-NAME spilling data from the byte compiler." (unless (comp-ctxt-output comp-ctxt) (setf (comp-ctxt-output comp-ctxt) - (make-temp-file (symbol-name function-name) nil ".eln"))) + (make-temp-file (comp-c-func-name function-name "freefn-") + nil ".eln"))) (let* ((f (symbol-function function-name)) (c-name (comp-c-func-name function-name "F")) (func (make-comp-func-l :name function-name diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index a13235b203..b9a0a8771e 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -369,6 +369,12 @@ Check that the resulting binaries do not differ." (should (equal (interactive-form #'comp-tests-free-fun-f) '(interactive)))) +(comp-deftest free-fun-silly-name () + "Check we are able to compile a single function." + (eval '(defun comp-tests/free\fun-f ()) t) + (native-compile #'comp-tests/free\fun-f) + (should (subr-native-elisp-p (symbol-function #'comp-tests/free\fun-f)))) + (comp-deftest bug-40187 () "Check function name shadowing. https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-03/msg00914.html." commit 79ca25c085f89760cb87c8e10378a00a4af3fec7 Author: Andrea Corallo Date: Mon Oct 19 21:48:31 2020 +0200 * Have `native-compile' do not expose `with-late-load' parameter This is really for internal use only by deferred compilation. * lisp/emacs-lisp/comp.el (comp-trampoline-compile) (comp-run-async-workers): Make use of `comp--native-compile'. (comp--native-compile): New function. (native-compile, batch-native-compile): Make use of `comp--native-compile'. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index a460340102..6c54085750 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2647,7 +2647,7 @@ Return the trampoline if found or nil otherwise." (byte-optimize nil) (comp-speed 0) (lexical-binding t)) - (native-compile + (comp--native-compile form nil (cl-loop for load-dir in comp-eln-load-path @@ -2796,7 +2796,7 @@ display a message." load-path ',load-path) ,comp-async-env-modifier-form (message "Compiling %s..." ,source-file) - (native-compile ,source-file ,(and load t)))) + (comp--native-compile ,source-file ,(and load t)))) (source-file1 source-file) ;; Make the closure works :/ (temp-file (make-temp-file (concat "emacs-async-comp-" @@ -2842,22 +2842,11 @@ display a message." ;; Reset it anyway. (clrhash comp-deferred-pending-h))) - -;;; Compiler entry points. - -;;;###autoload -(defun native-compile (function-or-file &optional with-late-load output) +(defun comp--native-compile (function-or-file &optional with-late-load output) "Compile FUNCTION-OR-FILE into native code. -This is the syncronous entry-point for the Emacs Lisp native -compiler. -FUNCTION-OR-FILE is a function symbol, a form or the -filename of an Emacs Lisp source file. +This serves as internal implementation of `native-compile'. When WITH-LATE-LOAD non-nil mark the compilation unit for late -load once finished compiling (internal use only). When OUTPUT is -non-nil use it as filename for the compiled object. -If FUNCTION-OR-FILE is a filename return the filename of the -compiled object. If FUNCTION-OR-FILE is a function symbol or a -form return the compiled function." +load once finished compiling." (comp-ensure-native-compiler) (unless (or (functionp function-or-file) (stringp function-or-file)) @@ -2891,6 +2880,23 @@ form return the compiled function." ;; So we return the compiled function. (native-elisp-load data)))) + +;;; Compiler entry points. + +;;;###autoload +(defun native-compile (function-or-file &optional output) + "Compile FUNCTION-OR-FILE into native code. +This is the syncronous entry-point for the Emacs Lisp native +compiler. +FUNCTION-OR-FILE is a function symbol, a form or the filename of +an Emacs Lisp source file. +When OUTPUT is non-nil use it as filename for the compiled +object. +If FUNCTION-OR-FILE is a filename return the filename of the +compiled object. If FUNCTION-OR-FILE is a function symbol or a +form return the compiled function." + (comp--native-compile function-or-file nil output)) + ;;;###autoload (defun batch-native-compile () "Run `native-compile' on remaining command-line arguments. @@ -2900,7 +2906,7 @@ Ultra cheap impersonation of `batch-byte-compile'." if (or (null byte-native-for-bootstrap) (cl-notany (lambda (re) (string-match re file)) comp-bootstrap-black-list)) - do (native-compile file) + do (comp--native-compile file) else do (byte-compile-file file))) commit d5791ba5feeb5500433ca43506dda13c7c67ce14 Merge: 03dfa83dc3 86dd9d12aa Author: Andrea Corallo Date: Sat Oct 17 08:00:34 2020 +0200 Merge remote-tracking branch 'savannah/master' into HEAD commit 03dfa83dc35738c9228b66b3d3f72753b344f939 Author: Andrea Corallo Date: Thu Oct 15 12:32:58 2020 +0200 * Do not check eln timestamp as superseded by source hashing (bug#43532) * src/lread.c (maybe_swap_for_eln): Remove eln file timestamp check given is now unnecessary. (openp): Update for new 'maybe_swap_for_eln' signature. diff --git a/src/lread.c b/src/lread.c index ea31131b75..6aab470eb2 100644 --- a/src/lread.c +++ b/src/lread.c @@ -1589,7 +1589,7 @@ directories, make sure the PREDICATE function returns `dir-ok' for them. */) If found replace the content of FILENAME and FD. */ static void -maybe_swap_for_eln (Lisp_Object *filename, int *fd, struct timespec mtime) +maybe_swap_for_eln (Lisp_Object *filename, int *fd) { #ifdef HAVE_NATIVE_COMP struct stat eln_st; @@ -1621,19 +1621,13 @@ maybe_swap_for_eln (Lisp_Object *filename, int *fd, struct timespec mtime) emacs_close (eln_fd); else { - struct timespec eln_mtime = get_stat_mtime (&eln_st); - if (timespec_cmp (eln_mtime, mtime) > 0) - { - *filename = eln_name; - emacs_close (*fd); - *fd = eln_fd; - /* Store the eln -> el relation. */ - Fputhash (Ffile_name_nondirectory (eln_name), - src_name, Vcomp_eln_to_el_h); - return; - } - else - emacs_close (eln_fd); + *filename = eln_name; + emacs_close (*fd); + *fd = eln_fd; + /* Store the eln -> el relation. */ + Fputhash (Ffile_name_nondirectory (eln_name), + src_name, Vcomp_eln_to_el_h); + return; } } } @@ -1878,7 +1872,7 @@ openp (Lisp_Object path, Lisp_Object str, Lisp_Object suffixes, } else { - maybe_swap_for_eln (&string, &fd, get_stat_mtime (&st)); + maybe_swap_for_eln (&string, &fd); /* We succeeded; return this descriptor and filename. */ if (storeptr) *storeptr = string; @@ -1890,7 +1884,7 @@ openp (Lisp_Object path, Lisp_Object str, Lisp_Object suffixes, /* No more suffixes. Return the newest. */ if (0 <= save_fd && ! CONSP (XCDR (tail))) { - maybe_swap_for_eln (&save_string, &save_fd, save_mtime); + maybe_swap_for_eln (&save_string, &save_fd); if (storeptr) *storeptr = save_string; SAFE_FREE (); commit f8505fd3d43dd95492855eac88922b5b27201e7a Merge: 03e98f93f7 b13e0c1501 Author: Andrea Corallo Date: Wed Oct 14 11:04:55 2020 +0200 Merge remote-tracking branch 'savannah/master' into HEAD commit 03e98f93f72c8a158a3584355bca174e2c63dce6 Author: Andrea Corallo Date: Tue Oct 13 22:48:22 2020 +0200 Use form native compilation in `comp-trampoline-compile' * lisp/emacs-lisp/comp.el (comp-trampoline-sym): Remove function. (comp-trampoline-filename): As we are introducing an ABI change in the eln trampoline format change the trampoline filename to disambiguate. (comp-trampoline-search): Rename from `comp-search-trampoline' and return directly the trampoline. (comp-trampoline-compile): Rework to use native form compilation in place of un-evaluating a function and return directly the trampoline. (comp-subr-trampoline-install): Update for `comp-trampoline-search' and `comp-trampoline-compile' new interfaces. * src/comp.c (Fcomp__install_trampoline): Store the trampoline itself as value in `comp-installed-trampolines-h'. (syms_of_comp): Doc update `comp-installed-trampolines-h'. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index cd13c44fa9..a460340102 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2598,13 +2598,9 @@ Prepare every function for final compilation and drive the C back-end." ;; Primitive funciton advice machinery -(defsubst comp-trampoline-sym (subr-name) - "Given SUBR-NAME return the trampoline function name." - (intern (concat "--subr-trampoline-" (symbol-name subr-name)))) - (defsubst comp-trampoline-filename (subr-name) "Given SUBR-NAME return the filename containing the trampoline." - (concat (comp-c-func-name subr-name "subr-trampoline-" t) ".eln")) + (concat (comp-c-func-name subr-name "subr--trampoline-" t) ".eln")) (defun comp-make-lambda-list-from-subr (subr) "Given SUBR return the equivalent lambda-list." @@ -2621,39 +2617,38 @@ Prepare every function for final compilation and drive the C back-end." (push (gensym "arg") lambda-list)) (reverse lambda-list))) -(defun comp-search-trampoline (subr-name) +(defun comp-trampoline-search (subr-name) "Search a trampoline file for SUBR-NAME. -Return the its filename if found or nil otherwise." +Return the trampoline if found or nil otherwise." (cl-loop with rel-filename = (comp-trampoline-filename subr-name) for dir in comp-eln-load-path for filename = (expand-file-name rel-filename (concat dir comp-native-version-dir)) when (file-exists-p filename) - do (cl-return filename))) + do (cl-return (native-elisp-load filename)))) (defun comp-trampoline-compile (subr-name) - "Synthesize and compile a trampoline for SUBR-NAME and return its filename." - (let ((trampoline-sym (comp-trampoline-sym subr-name)) - (lambda-list (comp-make-lambda-list-from-subr - (symbol-function subr-name))) - ;; Use speed 0 to maximize compilation speed and not to - ;; optimize away funcall calls! - (byte-optimize nil) - (comp-speed 0)) - ;; The synthesized trampoline must expose the exact same ABI of - ;; the primitive we are replacing in the function reloc table. - (defalias trampoline-sym - `(closure nil ,lambda-list - (let ((f #',subr-name)) - (,(if (memq '&rest lambda-list) #'apply 'funcall) - f - ,@(cl-loop - for arg in lambda-list - unless (memq arg '(&optional &rest)) - collect arg))))) + "Synthesize compile and return a trampoline for SUBR-NAME." + (let* ((lambda-list (comp-make-lambda-list-from-subr + (symbol-function subr-name))) + ;; The synthesized trampoline must expose the exact same ABI of + ;; the primitive we are replacing in the function reloc table. + (form `(lambda ,lambda-list + (let ((f #',subr-name)) + (,(if (memq '&rest lambda-list) #'apply 'funcall) + f + ,@(cl-loop + for arg in lambda-list + unless (memq arg '(&optional &rest)) + collect arg))))) + ;; Use speed 0 to maximize compilation speed and not to + ;; optimize away funcall calls! + (byte-optimize nil) + (comp-speed 0) + (lexical-binding t)) (native-compile - trampoline-sym nil + form nil (cl-loop for load-dir in comp-eln-load-path for dir = (concat load-dir comp-native-version-dir) @@ -2674,14 +2669,13 @@ Return the its filename if found or nil otherwise." "Make SUBR-NAME effectively advice-able when called from native code." (unless (or (memq subr-name comp-never-optimize-functions) (gethash subr-name comp-installed-trampolines-h)) - (let ((trampoline-sym (comp-trampoline-sym subr-name))) - (cl-assert (subr-primitive-p (symbol-function subr-name))) - (load (or (comp-search-trampoline subr-name) - (comp-trampoline-compile subr-name)) - nil t) - (cl-assert - (subr-native-elisp-p (symbol-function trampoline-sym))) - (comp--install-trampoline subr-name (symbol-function trampoline-sym))))) + (cl-assert (subr-primitive-p (symbol-function subr-name))) + (comp--install-trampoline + subr-name + (or (comp-trampoline-search subr-name) + (comp-trampoline-compile subr-name) + ;; Should never happen. + (cl-assert nil))))) ;; Some entry point support code. diff --git a/src/comp.c b/src/comp.c index f80172e89b..0c555578f8 100644 --- a/src/comp.c +++ b/src/comp.c @@ -4158,7 +4158,7 @@ DEFUN ("comp--install-trampoline", Fcomp__install_trampoline, if (EQ (subr, orig_subr)) { freloc.link_table[i] = XSUBR (trampoline)->function.a0; - Fputhash (subr_name, Qt, Vcomp_installed_trampolines_h); + Fputhash (subr_name, trampoline, Vcomp_installed_trampolines_h); return Qt; } i++; @@ -5296,7 +5296,9 @@ The last directory of this list is assumed to be the system one. */); redefinable effectivelly. */); DEFVAR_LISP ("comp-installed-trampolines-h", Vcomp_installed_trampolines_h, - doc: /* Hash table subr-name -> bool. */); + doc: /* Hash table subr-name -> installed trampoline. +This is used to prevent double trampoline instantiation but also to +protect the trampolines against GC. */); Vcomp_installed_trampolines_h = CALLN (Fmake_hash_table); Fprovide (intern_c_string ("nativecomp"), Qnil); commit e9c150b5c2efee4fad0e41668f5bf1ecb9fad0df Author: Andrea Corallo Date: Tue Oct 13 21:43:01 2020 +0200 * Add a test to verify form native compilation. * test/src/comp-tests.el (comp-deftest): Fix typo. (compile-forms): New test. diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 79bac3f711..a13235b203 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -46,7 +46,7 @@ "Define a test for the native compiler tagging it as :nativecomp." (declare (indent defun) (doc-string 3)) - `(ert-deftest ,(intern (concat "compt-tests-" (symbol-name name))) ,args + `(ert-deftest ,(intern (concat "comp-tests-" (symbol-name name))) ,args :tags '(:nativecomp) ,@docstring-and-body)) @@ -409,6 +409,17 @@ https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-03/msg00914.html." (should (eq (comp-test-primitive-redefine-f 10 2) 'xxx)) (should (equal comp-test-primitive-redefine-args '(10 2))))) +(comp-deftest compile-forms () + "Verify lambda form native compilation." + (should-error (native-compile '(+ 1 foo))) + (let ((f (native-compile '(lambda (x) (1+ x))))) + (should (subr-native-elisp-p f)) + (should (= (funcall f 2) 3))) + (let* ((lexical-binding nil) + (f (native-compile '(lambda (x) (1+ x))))) + (should (subr-native-elisp-p f)) + (should (= (funcall f 2) 3)))) + ;;;;;;;;;;;;;;;;;;;;; ;; Tromey's tests. ;; commit 4f0e87903095da1225830e27ef27e61ba9ff08af Author: Andrea Corallo Date: Mon Oct 12 22:34:57 2020 +0200 Rework `native-compile' interface so it can return compiled functions * lisp/emacs-lisp/comp.el (native-compile): Return the compiled function when the input is a symbol or a form. * test/src/comp-tests.el (free-fun, tco, fw-prop): Update tests for new `native-compile' interface. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 98f552599e..cd13c44fa9 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2854,12 +2854,16 @@ display a message." ;;;###autoload (defun native-compile (function-or-file &optional with-late-load output) "Compile FUNCTION-OR-FILE into native code. -This is the entry-point for the Emacs Lisp native compiler. -FUNCTION-OR-FILE is a function symbol or a path to an Elisp file. -When WITH-LATE-LOAD non-nil mark the compilation unit for late load -once finished compiling (internal use only). -When OUTPUT is non-nil use it as filename for the compiled object. -Return the compile object filename." +This is the syncronous entry-point for the Emacs Lisp native +compiler. +FUNCTION-OR-FILE is a function symbol, a form or the +filename of an Emacs Lisp source file. +When WITH-LATE-LOAD non-nil mark the compilation unit for late +load once finished compiling (internal use only). When OUTPUT is +non-nil use it as filename for the compiled object. +If FUNCTION-OR-FILE is a filename return the filename of the +compiled object. If FUNCTION-OR-FILE is a function symbol or a +form return the compiled function." (comp-ensure-native-compiler) (unless (or (functionp function-or-file) (stringp function-or-file)) @@ -2888,7 +2892,10 @@ Return the compile object filename." (signal (car err) (if (consp err-val) (cons function-or-file err-val) (list function-or-file err-val)))))) - data)) + (if (stringp function-or-file) + data + ;; So we return the compiled function. + (native-elisp-load data)))) ;;;###autoload (defun batch-native-compile () diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 317a6113af..79bac3f711 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -359,7 +359,7 @@ Check that the resulting binaries do not differ." (interactive) 3) t) - (load (native-compile #'comp-tests-free-fun-f)) + (native-compile #'comp-tests-free-fun-f) (should (subr-native-elisp-p (symbol-function #'comp-tests-free-fun-f))) (should (= (comp-tests-free-fun-f) 3)) @@ -692,7 +692,7 @@ CHECKER should always return nil to have a pass." b (comp-tests-tco-f (+ a b) a (- count 1)))) t) - (load (native-compile #'comp-tests-tco-f)) + (native-compile #'comp-tests-tco-f) (should (subr-native-elisp-p (symbol-function #'comp-tests-tco-f))) (should (= (comp-tests-tco-f 1 0 10) 55)))) @@ -714,7 +714,7 @@ CHECKER should always return nil to have a pass." (c (concat a b))) ; <= has to optimize (length c))) ; <= has to optimize t) - (load (native-compile #'comp-tests-fw-prop-1-f)) + (native-compile #'comp-tests-fw-prop-1-f) (should (subr-native-elisp-p (symbol-function #'comp-tests-fw-prop-1-f))) (should (= (comp-tests-fw-prop-1-f) 6)))) commit 8861ee8b087b4e5d9ac9186a2c2d8e44b07fc186 Author: Andrea Corallo Date: Mon Oct 12 22:11:06 2020 +0200 Have `native-elisp-load' return the last registerd function * lisp/emacs-lisp/comp.el (comp-emit-for-top-level): Synthesize 'top_level_run' so it returns the last value returned by `comp--register-subr'. * src/comp.c (load_comp_unit): Return what 'top_level_run' returns. (Fnative_elisp_load): Return what 'load_comp_unit' returns. * src/comp.h (load_comp_unit): Update signature. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 89b4230dc2..98f552599e 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1480,24 +1480,26 @@ the annotation emission." (f (gethash c-name (comp-ctxt-funcs-h comp-ctxt))) (args (comp-prepare-args-for-top-level f))) (cl-assert (and name f)) - (comp-emit (comp-call (if for-late-load - 'comp--late-register-subr - 'comp--register-subr) - (make-comp-mvar :constant name) - (car args) - (cdr args) - (make-comp-mvar :constant c-name) - (make-comp-mvar - :constant - (let* ((h (comp-ctxt-function-docs comp-ctxt)) - (i (hash-table-count h))) - (puthash i (comp-func-doc f) h) - i)) - (make-comp-mvar :constant - (comp-func-int-spec f)) - ;; This is the compilation unit it-self passed as - ;; parameter. - (make-comp-mvar :slot 0))))) + (comp-emit + `(set ,(make-comp-mvar :slot 1) + ,(comp-call (if for-late-load + 'comp--late-register-subr + 'comp--register-subr) + (make-comp-mvar :constant name) + (car args) + (cdr args) + (make-comp-mvar :constant c-name) + (make-comp-mvar + :constant + (let* ((h (comp-ctxt-function-docs comp-ctxt)) + (i (hash-table-count h))) + (puthash i (comp-func-doc f) h) + i)) + (make-comp-mvar :constant + (comp-func-int-spec f)) + ;; This is the compilation unit it-self passed as + ;; parameter. + (make-comp-mvar :slot 0)))))) (cl-defmethod comp-emit-for-top-level ((form byte-to-native-top-level) for-late-load) @@ -1558,7 +1560,12 @@ into the C code forwarding the compilation unit." "late_top_level_run" "top_level_run") :args (make-comp-args :min 1 :max 1) - :frame-size 1 + ;; Frame is 2 wide: Slot 0 is the + ;; compilation unit being loaded + ;; (incoming parameter). Slot 1 is + ;; the last function being + ;; registered. + :frame-size 2 :speed comp-speed)) (comp-func func) (comp-pass (make-comp-limplify @@ -1575,7 +1582,7 @@ into the C code forwarding the compilation unit." (comp-ctxt-byte-func-to-func-h comp-ctxt)) (mapc (lambda (x) (comp-emit-for-top-level x for-late-load)) (comp-ctxt-top-level-forms comp-ctxt)) - (comp-emit `(return ,(make-comp-mvar :constant t))) + (comp-emit `(return ,(make-comp-mvar :slot 1))) (puthash 0 (comp-func-frame-size func) (comp-func-array-h func)) (comp-limplify-finalize-function func))) diff --git a/src/comp.c b/src/comp.c index 0b5a49fd1f..f80172e89b 100644 --- a/src/comp.c +++ b/src/comp.c @@ -4768,10 +4768,11 @@ unset_cu_load_ongoing (Lisp_Object comp_u) XNATIVE_COMP_UNIT (comp_u)->load_ongoing = false; } -void +Lisp_Object load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u, bool loading_dump, bool late_load) { + Lisp_Object res = Qnil; dynlib_handle_ptr handle = comp_u->handle; Lisp_Object comp_u_lisp_obj; XSETNATIVE_COMP_UNIT (comp_u_lisp_obj, comp_u); @@ -4897,7 +4898,7 @@ load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u, bool loading_dump, } /* Executing this will perform all the expected environment modifications. */ - top_level_run (comp_u_lisp_obj); + res = top_level_run (comp_u_lisp_obj); /* Make sure data_ephemeral_vec still exists after top_level_run has run. Guard against sibling call optimization (or any other). */ data_ephemeral_vec = data_ephemeral_vec; @@ -4910,7 +4911,7 @@ load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u, bool loading_dump, register_native_comp_unit (comp_u_lisp_obj); - return; + return res; } Lisp_Object @@ -5090,9 +5091,7 @@ DEFUN ("native-elisp-load", Fnative_elisp_load, Snative_elisp_load, 1, 2, 0, comp_u->data_vec = Qnil; comp_u->lambda_gc_guard_h = CALLN (Fmake_hash_table, QCtest, Qeq); comp_u->lambda_c_name_idx_h = CALLN (Fmake_hash_table, QCtest, Qequal); - load_comp_unit (comp_u, false, !NILP (late_load)); - - return Qt; + return load_comp_unit (comp_u, false, !NILP (late_load)); } #endif /* HAVE_NATIVE_COMP */ diff --git a/src/comp.h b/src/comp.h index 5c7bed6a30..077250ea86 100644 --- a/src/comp.h +++ b/src/comp.h @@ -75,8 +75,8 @@ XNATIVE_COMP_UNIT (Lisp_Object a) extern void hash_native_abi (void); -extern void load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u, - bool loading_dump, bool late_load); +extern Lisp_Object load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u, + bool loading_dump, bool late_load); extern Lisp_Object native_function_doc (Lisp_Object function); commit 4bea0c0b1d907d676cc9abc8d7048103c10b8d79 Author: Andrea Corallo Date: Sat Oct 10 22:07:59 2020 +0200 * Allow for lambda forms as native compilation input * lisp/emacs-lisp/comp.el (comp-spill-lap-function): Add new specialized method for compiling a lambda form. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 26654a300a..89b4230dc2 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -698,6 +698,45 @@ clashes." (puthash 0 (comp-func-frame-size func) (comp-func-array-h func)) (comp-add-func-to-ctxt func)))) +(cl-defmethod comp-spill-lap-function ((form list)) + "Byte-compile FORM spilling data from the byte compiler." + (unless (eq (car-safe form) 'lambda) + (signal 'native-compiler-error + "Cannot native compile, form is not a lambda")) + (unless (comp-ctxt-output comp-ctxt) + (setf (comp-ctxt-output comp-ctxt) + (make-temp-file "comp-lambda-" nil ".eln"))) + (let* ((byte-code (byte-compile form)) + (c-name (comp-c-func-name "anonymous-lambda" "F")) + (func (if (comp-lex-byte-func-p byte-code) + (make-comp-func-l :c-name c-name + :doc (documentation form t) + :int-spec (interactive-form form) + :speed comp-speed) + (make-comp-func-d :c-name c-name + :doc (documentation form t) + :int-spec (interactive-form form) + :speed comp-speed)))) + (let ((lap (byte-to-native-lambda-lap + (gethash (aref byte-code 1) + byte-to-native-lambdas-h)))) + (cl-assert lap) + (comp-log lap 2) + (if (comp-func-l-p func) + (setf (comp-func-l-args func) + (comp-decrypt-arg-list (aref byte-code 0) byte-code)) + (setf (comp-func-d-lambda-list func) (cadr form))) + (setf (comp-func-lap func) lap + (comp-func-frame-size func) (comp-byte-frame-size + byte-code)) + (setf (comp-func-byte-func func) byte-code + (comp-ctxt-top-level-forms comp-ctxt) + (list (make-byte-to-native-func-def :name '--anonymous-lambda + :c-name c-name))) + ;; Create the default array. + (puthash 0 (comp-func-frame-size func) (comp-func-array-h func)) + (comp-add-func-to-ctxt func)))) + (defun comp-intern-func-in-ctxt (_ obj) "Given OBJ of type `byte-to-native-lambda', create a function in `comp-ctxt'." (when-let ((byte-func (byte-to-native-lambda-byte-func obj))) commit fda798808f8b518313cff3363a6ba72baed2d758 Author: Andrea Corallo Date: Sat Oct 10 21:16:40 2020 +0200 * Move context output computation in `comp-spill-lap-function' * lisp/emacs-lisp/comp.el (comp-spill-lap-function): Move output filename computation here. (native-compile): From here. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index b4a86fc83e..26654a300a 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -662,6 +662,9 @@ clashes." (cl-defmethod comp-spill-lap-function ((function-name symbol)) "Byte-compile FUNCTION-NAME spilling data from the byte compiler." + (unless (comp-ctxt-output comp-ctxt) + (setf (comp-ctxt-output comp-ctxt) + (make-temp-file (symbol-name function-name) nil ".eln"))) (let* ((f (symbol-function function-name)) (c-name (comp-c-func-name function-name "F")) (func (make-comp-func-l :name function-name @@ -740,6 +743,11 @@ clashes." (byte-compile-file filename) (unless byte-to-native-top-level-forms (signal 'native-compiler-error-empty-byte filename)) + (unless (comp-ctxt-output comp-ctxt) + (setf (comp-ctxt-output comp-ctxt) (comp-el-to-eln-filename + filename + (when byte-native-for-bootstrap + (car (last comp-eln-load-path)))))) (setf (comp-ctxt-top-level-forms comp-ctxt) (cl-loop for form in (reverse byte-to-native-top-level-forms) @@ -2815,18 +2823,8 @@ Return the compile object filename." (comp-native-compiling t) ;; Have byte compiler signal an error when compilation fails. (byte-compile-debug t) - (comp-ctxt - (make-comp-ctxt - :output (or (when output - (expand-file-name output)) - (if (symbolp function-or-file) - (make-temp-file (symbol-name function-or-file) nil - ".eln") - (comp-el-to-eln-filename - function-or-file - (when byte-native-for-bootstrap - (car (last comp-eln-load-path)))))) - :with-late-load with-late-load))) + (comp-ctxt (make-comp-ctxt :output output + :with-late-load with-late-load))) (comp-log "\n \n" 1) (condition-case err (mapc (lambda (pass) commit 237fd33aef7e0f4b187ee0c1f367f27a90d603dc Author: Brian Leung Date: Mon Oct 12 18:55:38 2020 +0000 Fix some compilation warnings in non nativecomp build (bug#43892) * lisp/emacs-lisp/advice.el (comp-subr-trampoline-install): Declare function. * lisp/emacs-lisp/find-func.el (comp-eln-to-el-h): Declare variable. * lisp/emacs-lisp/nadvice.el (comp-subr-trampoline-install): Declare function. * lisp/files.el (comp-eln-to-el-h): Declare variable. * lisp/help.el (subr-native-lambda-list): Declare function. diff --git a/lisp/emacs-lisp/advice.el b/lisp/emacs-lisp/advice.el index fb67de3a02..509e255191 100644 --- a/lisp/emacs-lisp/advice.el +++ b/lisp/emacs-lisp/advice.el @@ -2052,6 +2052,8 @@ in that CLASS." function class name))) (error "ad-remove-advice: `%s' is not advised" function))) +(declare-function comp-subr-trampoline-install "comp") + ;;;###autoload (defun ad-add-advice (function advice class position) "Add a piece of ADVICE to FUNCTION's list of advices in CLASS. diff --git a/lisp/emacs-lisp/find-func.el b/lisp/emacs-lisp/find-func.el index 9e4d8cf1aa..4417082971 100644 --- a/lisp/emacs-lisp/find-func.el +++ b/lisp/emacs-lisp/find-func.el @@ -178,6 +178,8 @@ See the functions `find-function' and `find-variable'." (setq name rel)))) (unless (equal name library) name))) +(defvar comp-eln-to-el-h) + (defun find-library-name (library) "Return the absolute file name of the Emacs Lisp source of LIBRARY. LIBRARY should be a string (the name of the library)." diff --git a/lisp/emacs-lisp/nadvice.el b/lisp/emacs-lisp/nadvice.el index 8b60c08440..e68c135608 100644 --- a/lisp/emacs-lisp/nadvice.el +++ b/lisp/emacs-lisp/nadvice.el @@ -316,6 +316,8 @@ is also interactive. There are 3 cases: `(advice--add-function ,where (gv-ref ,(advice--normalize-place place)) ,function ,props)) +(declare-function comp-subr-trampoline-install "comp") + ;;;###autoload (defun advice--add-function (where ref function props) (when (and (featurep 'nativecomp) diff --git a/lisp/files.el b/lisp/files.el index 833a188b03..1d330ce87b 100644 --- a/lisp/files.el +++ b/lisp/files.el @@ -900,6 +900,8 @@ recursion." (read-file-name "Load file: " nil nil 'lambda)))) (load (expand-file-name file) nil nil t)) +(defvar comp-eln-to-el-h) + (defun locate-file (filename path &optional suffixes predicate) "Search for FILENAME through PATH. If found, return the absolute file name of FILENAME; otherwise diff --git a/lisp/help.el b/lisp/help.el index c166b63a56..1a3fd35e44 100644 --- a/lisp/help.el +++ b/lisp/help.el @@ -1320,6 +1320,8 @@ ARGLIST can also be t or a string of the form \"(FUN ARG1 ARG2 ...)\"." (error "Unrecognized usage format")) (help--make-usage-docstring 'fn arglist))))) +(declare-function subr-native-lambda-list "data.c") + (defun help-function-arglist (def &optional preserve-names) "Return a formal argument list for the function DEF. If PRESERVE-NAMES is non-nil, return a formal arglist that uses commit a3304feb9be1489036574fdac2a4a3e4e7a0c38a Author: Andrea Corallo Date: Mon Oct 12 21:25:00 2020 +0200 Revert "Fix some compilation warnings in non nativecomp build (bug#43892)" This reverts commit 6606ec8e313bf48a1ac7b63c52bfeb64c4257107. diff --git a/lisp/emacs-lisp/advice.el b/lisp/emacs-lisp/advice.el index 509e255191..fb67de3a02 100644 --- a/lisp/emacs-lisp/advice.el +++ b/lisp/emacs-lisp/advice.el @@ -2052,8 +2052,6 @@ in that CLASS." function class name))) (error "ad-remove-advice: `%s' is not advised" function))) -(declare-function comp-subr-trampoline-install "comp") - ;;;###autoload (defun ad-add-advice (function advice class position) "Add a piece of ADVICE to FUNCTION's list of advices in CLASS. diff --git a/lisp/emacs-lisp/find-func.el b/lisp/emacs-lisp/find-func.el index 4417082971..9e4d8cf1aa 100644 --- a/lisp/emacs-lisp/find-func.el +++ b/lisp/emacs-lisp/find-func.el @@ -178,8 +178,6 @@ See the functions `find-function' and `find-variable'." (setq name rel)))) (unless (equal name library) name))) -(defvar comp-eln-to-el-h) - (defun find-library-name (library) "Return the absolute file name of the Emacs Lisp source of LIBRARY. LIBRARY should be a string (the name of the library)." diff --git a/lisp/emacs-lisp/nadvice.el b/lisp/emacs-lisp/nadvice.el index e68c135608..8b60c08440 100644 --- a/lisp/emacs-lisp/nadvice.el +++ b/lisp/emacs-lisp/nadvice.el @@ -316,8 +316,6 @@ is also interactive. There are 3 cases: `(advice--add-function ,where (gv-ref ,(advice--normalize-place place)) ,function ,props)) -(declare-function comp-subr-trampoline-install "comp") - ;;;###autoload (defun advice--add-function (where ref function props) (when (and (featurep 'nativecomp) diff --git a/lisp/files.el b/lisp/files.el index 1d330ce87b..833a188b03 100644 --- a/lisp/files.el +++ b/lisp/files.el @@ -900,8 +900,6 @@ recursion." (read-file-name "Load file: " nil nil 'lambda)))) (load (expand-file-name file) nil nil t)) -(defvar comp-eln-to-el-h) - (defun locate-file (filename path &optional suffixes predicate) "Search for FILENAME through PATH. If found, return the absolute file name of FILENAME; otherwise diff --git a/lisp/help.el b/lisp/help.el index 1a3fd35e44..c166b63a56 100644 --- a/lisp/help.el +++ b/lisp/help.el @@ -1320,8 +1320,6 @@ ARGLIST can also be t or a string of the form \"(FUN ARG1 ARG2 ...)\"." (error "Unrecognized usage format")) (help--make-usage-docstring 'fn arglist))))) -(declare-function subr-native-lambda-list "data.c") - (defun help-function-arglist (def &optional preserve-names) "Return a formal argument list for the function DEF. If PRESERVE-NAMES is non-nil, return a formal arglist that uses commit 6606ec8e313bf48a1ac7b63c52bfeb64c4257107 Author: Andrea Corallo Date: Mon Oct 12 18:55:38 2020 +0000 Fix some compilation warnings in non nativecomp build (bug#43892) * lisp/emacs-lisp/advice.el (comp-subr-trampoline-install): Declare function. * lisp/emacs-lisp/find-func.el (comp-eln-to-el-h): Declare variable. * lisp/emacs-lisp/nadvice.el (comp-subr-trampoline-install): Declare function. * lisp/files.el (comp-eln-to-el-h): Declare variable. * lisp/help.el (subr-native-lambda-list): Declare function. diff --git a/lisp/emacs-lisp/advice.el b/lisp/emacs-lisp/advice.el index fb67de3a02..509e255191 100644 --- a/lisp/emacs-lisp/advice.el +++ b/lisp/emacs-lisp/advice.el @@ -2052,6 +2052,8 @@ in that CLASS." function class name))) (error "ad-remove-advice: `%s' is not advised" function))) +(declare-function comp-subr-trampoline-install "comp") + ;;;###autoload (defun ad-add-advice (function advice class position) "Add a piece of ADVICE to FUNCTION's list of advices in CLASS. diff --git a/lisp/emacs-lisp/find-func.el b/lisp/emacs-lisp/find-func.el index 9e4d8cf1aa..4417082971 100644 --- a/lisp/emacs-lisp/find-func.el +++ b/lisp/emacs-lisp/find-func.el @@ -178,6 +178,8 @@ See the functions `find-function' and `find-variable'." (setq name rel)))) (unless (equal name library) name))) +(defvar comp-eln-to-el-h) + (defun find-library-name (library) "Return the absolute file name of the Emacs Lisp source of LIBRARY. LIBRARY should be a string (the name of the library)." diff --git a/lisp/emacs-lisp/nadvice.el b/lisp/emacs-lisp/nadvice.el index 8b60c08440..e68c135608 100644 --- a/lisp/emacs-lisp/nadvice.el +++ b/lisp/emacs-lisp/nadvice.el @@ -316,6 +316,8 @@ is also interactive. There are 3 cases: `(advice--add-function ,where (gv-ref ,(advice--normalize-place place)) ,function ,props)) +(declare-function comp-subr-trampoline-install "comp") + ;;;###autoload (defun advice--add-function (where ref function props) (when (and (featurep 'nativecomp) diff --git a/lisp/files.el b/lisp/files.el index 833a188b03..1d330ce87b 100644 --- a/lisp/files.el +++ b/lisp/files.el @@ -900,6 +900,8 @@ recursion." (read-file-name "Load file: " nil nil 'lambda)))) (load (expand-file-name file) nil nil t)) +(defvar comp-eln-to-el-h) + (defun locate-file (filename path &optional suffixes predicate) "Search for FILENAME through PATH. If found, return the absolute file name of FILENAME; otherwise diff --git a/lisp/help.el b/lisp/help.el index c166b63a56..1a3fd35e44 100644 --- a/lisp/help.el +++ b/lisp/help.el @@ -1320,6 +1320,8 @@ ARGLIST can also be t or a string of the form \"(FUN ARG1 ARG2 ...)\"." (error "Unrecognized usage format")) (help--make-usage-docstring 'fn arglist))))) +(declare-function subr-native-lambda-list "data.c") + (defun help-function-arglist (def &optional preserve-names) "Return a formal argument list for the function DEF. If PRESERVE-NAMES is non-nil, return a formal arglist that uses commit feed53f8b5da0e58cce412cd41a52883dba6c1be Author: Andrea Corallo Date: Sat Oct 10 21:30:04 2020 +0200 * lisp/help.el (help-function-arglist): Fix non nativecomp builds (bug#43914) diff --git a/lisp/help.el b/lisp/help.el index 4d0c4d5d98..c166b63a56 100644 --- a/lisp/help.el +++ b/lisp/help.el @@ -1335,7 +1335,9 @@ the same names as used in the original source code, when possible." ((and (byte-code-function-p def) (listp (aref def 0))) (aref def 0)) ((eq (car-safe def) 'lambda) (nth 1 def)) ((eq (car-safe def) 'closure) (nth 2 def)) - ((and (subrp def) (listp (subr-native-lambda-list def))) + ((and (featurep 'nativecomp) + (subrp def) + (listp (subr-native-lambda-list def))) (subr-native-lambda-list def)) ((or (and (byte-code-function-p def) (integerp (aref def 0))) (subrp def) (module-function-p def)) commit 4b924ef87d69d56ef78604fbcb50399578f83f5a Author: Andrea Corallo Date: Sun Sep 27 23:43:35 2020 +0200 * As edges are indexed store them in an hash table * lisp/emacs-lisp/comp.el (comp-edge): Update doc for 'number' slot. (comp-func): Rename 'edges' slot into 'edges-h'. (comp-log-edges): Update logic for edges in an hash table. (comp-clean-ssa, comp-compute-edges): Likewise. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index be29f84cd3..b4a86fc83e 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -336,7 +336,7 @@ into it.") (dst nil :type comp-block) (number nil :type number :documentation "The index number corresponding to this edge in the - edge vector.")) + edge hash.")) (defun comp-block-preds (basic-block) "Given BASIC-BLOCK return the list of its predecessors." @@ -371,8 +371,8 @@ CFG is mutated by a pass.") :documentation "Basic block name -> basic block.") (lap-block (make-hash-table :test #'equal) :type hash-table :documentation "LAP lable -> LIMPLE basic block name.") - (edges () :type list - :documentation "List of edges connecting basic blocks.") + (edges-h (make-hash-table) :type hash-table + :documentation "Hash edge-num -> edge connecting basic two blocks.") (block-cnt-gen (funcall #'comp-gen-counter) :type function :documentation "Generates block numbers.") (edge-cnt-gen (funcall #'comp-gen-counter) :type function @@ -555,16 +555,16 @@ VERBOSITY is a number between 0 and 3." (defun comp-log-edges (func) "Log edges in FUNC." - (let ((edges (comp-func-edges func))) + (let ((edges (comp-func-edges-h func))) (comp-log (format "\nEdges in function: %s\n" (comp-func-name func)) 2) - (mapc (lambda (e) - (comp-log (format "n: %d src: %s dst: %s\n" - (comp-edge-number e) - (comp-block-name (comp-edge-src e)) - (comp-block-name (comp-edge-dst e))) - 2)) + (maphash (lambda (_ e) + (comp-log (format "n: %d src: %s dst: %s\n" + (comp-edge-number e) + (comp-block-name (comp-edge-src e)) + (comp-block-name (comp-edge-dst e))) + 2)) edges))) @@ -1693,7 +1693,7 @@ into the C code forwarding the compilation unit." (defun comp-clean-ssa (f) "Clean-up SSA for funtion F." - (setf (comp-func-edges f) ()) + (setf (comp-func-edges-h f) (make-hash-table)) (cl-loop for b being each hash-value of (comp-func-blocks f) do (setf (comp-block-in-edges b) () @@ -1709,12 +1709,12 @@ into the C code forwarding the compilation unit." (defun comp-compute-edges () "Compute the basic block edges for the current function." - (cl-flet ((edge-add (&rest args) - (push - (apply #'make--comp-edge - :number (funcall (comp-func-edge-cnt-gen comp-func)) - args) - (comp-func-edges comp-func)))) + (cl-flet ((edge-add (&rest args &aux (n (funcall + (comp-func-edge-cnt-gen comp-func)))) + (puthash + n + (apply #'make--comp-edge :number n args) + (comp-func-edges-h comp-func)))) (cl-loop with blocks = (comp-func-blocks comp-func) for bb being each hash-value of blocks @@ -1738,18 +1738,16 @@ into the C code forwarding the compilation unit." (list "block does not end with a branch" bb (comp-func-name comp-func))))) - finally - (setf (comp-func-edges comp-func) - (nreverse (comp-func-edges comp-func))) ;; Update edge refs into blocks. + finally (cl-loop - for edge in (comp-func-edges comp-func) + for edge being the hash-value in (comp-func-edges-h comp-func) do (push edge (comp-block-out-edges (comp-edge-src edge))) (push edge (comp-block-in-edges (comp-edge-dst edge)))) - (comp-log-edges comp-func)))) + (comp-log-edges comp-func)))) (defun comp-collect-rev-post-order (basic-block) "Walk BASIC-BLOCK children and return their name in reversed post-order." commit 96f59a9faf375409a0301a54fcb46fc2325a9cc2 Author: Andrea Corallo Date: Sun Sep 27 23:24:24 2020 +0200 * Add into phi l-value args basic block names * lisp/emacs-lisp/comp.el (comp-ssa-rename-insn): Clean-up a leftover space. (comp-finalize-phis): Cons the blasic block name providing the mvar together with the mvar itself while forming the phi. (comp-fwprop-insn): Destructure correctly the phi. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index a4f2b6c36c..be29f84cd3 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1920,7 +1920,7 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non-nil." (`(fetch-handler . ,_) ;; Clobber all no matter what! (setf (aref frame slot-n) (make-comp-ssa-mvar :slot slot-n))) - (`(phi ,n) + (`(phi ,n) (when (equal n slot-n) (new-lvalue))) (_ @@ -1958,7 +1958,8 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non-nil." for e in (comp-block-in-edges b) for b = (comp-edge-src e) for in-frame = (comp-block-final-frame b) - collect (aref in-frame slot-n))))) + collect (cons (aref in-frame slot-n) + (comp-block-name b)))))) (cl-loop for b being each hash-value of (comp-func-blocks comp-func) do (cl-loop for (op . args) in (comp-block-insns b) @@ -2105,7 +2106,7 @@ Forward propagate immediate involed in assignments." (setf (comp-mvar-const-vld lval) t (comp-mvar-constant lval) v (comp-mvar-type lval) (comp-strict-type-of v))) - (`(phi ,lval . ,rest) + (`(phi (,lval . _) . ,rest) ;; Forward const prop here. (when-let* ((vld (cl-every #'comp-mvar-const-vld rest)) (consts (mapcar #'comp-mvar-constant rest)) commit 8b135af5bbdfb6cf561f92a02ef92e855acc04dd Author: Andrea Corallo Date: Sat Oct 10 18:18:09 2020 +0200 Provide feature nativecomp and make use of it * lisp/emacs-lisp/comp.el (comp-ensure-native-compiler): Use `featurep' to identify if the native compiler is available. * lisp/emacs-lisp/nadvice.el (advice--add-function): Likewise. * lisp/emacs-lisp/package.el (package--delete-directory): Likewise. * lisp/loadup.el: Likewise. * src/comp.c (syms_of_comp): Provide feature nativecomp. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index d860fa31f0..a4f2b6c36c 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -422,7 +422,7 @@ CFG is mutated by a pass.") Raise an error otherwise. To be used by all entry points." (cond - ((null (boundp 'comp-ctxt)) + ((null (featurep 'nativecomp)) (error "Emacs not compiled with native compiler support (--with-nativecomp)")) ((null (native-comp-available-p)) (error "Cannot find libgccjit")))) diff --git a/lisp/emacs-lisp/nadvice.el b/lisp/emacs-lisp/nadvice.el index 0396132585..8b60c08440 100644 --- a/lisp/emacs-lisp/nadvice.el +++ b/lisp/emacs-lisp/nadvice.el @@ -318,7 +318,7 @@ is also interactive. There are 3 cases: ;;;###autoload (defun advice--add-function (where ref function props) - (when (and (boundp 'comp-ctxt) + (when (and (featurep 'nativecomp) (subr-primitive-p (gv-deref ref))) (let ((subr-name (intern (subr-name (gv-deref ref))))) ;; Requiring the native compiler to advice `macroexpand' cause a diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index ac1396f88d..c0125e6472 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -2207,7 +2207,7 @@ If some packages are not installed propose to install them." "Delete DIR recursively. Clean-up the corresponding .eln files if Emacs is native compiled." - (when (boundp 'comp-ctxt) + (when (featurep 'nativecomp) (cl-loop for file in (directory-files-recursively dir ".el\\'") do (comp-clean-up-stale-eln (comp-el-to-eln-filename file)))) diff --git a/lisp/loadup.el b/lisp/loadup.el index 91126703d1..827087f763 100644 --- a/lisp/loadup.el +++ b/lisp/loadup.el @@ -449,7 +449,7 @@ lost after dumping"))) ;; At this point, we're ready to resume undo recording for scratch. (buffer-enable-undo "*scratch*") -(when (boundp 'comp-ctxt) +(when (featurep 'nativecomp) ;; Fix the compilation unit filename to have it working when ;; when installed or if the source directory got moved. This is set to be ;; a pair in the form: (rel-path-from-install-bin . rel-path-from-local-bin). @@ -510,7 +510,7 @@ lost after dumping"))) ((equal dump-mode "bootstrap") "emacs") ((equal dump-mode "pbootstrap") "bootstrap-emacs.pdmp") (t (error "unrecognized dump mode %s" dump-mode))))) - (when (and (boundp 'comp-ctxt) + (when (and (featurep 'nativecomp) (equal dump-mode "pdump")) ;; Don't enable this before bootstrap is completed the as the ;; compiler infrastructure may not be usable. diff --git a/src/comp.c b/src/comp.c index 13343de3d8..0b5a49fd1f 100644 --- a/src/comp.c +++ b/src/comp.c @@ -5300,6 +5300,7 @@ The last directory of this list is assumed to be the system one. */); doc: /* Hash table subr-name -> bool. */); Vcomp_installed_trampolines_h = CALLN (Fmake_hash_table); + Fprovide (intern_c_string ("nativecomp"), Qnil); #endif /* #ifdef HAVE_NATIVE_COMP */ defsubr (&Snative_comp_available_p); commit 77fa6befb478f49a47ef1cee88e2c791e0037617 Author: Andrea Corallo Date: Sat Oct 10 17:54:27 2020 +0200 * lisp/emacs-lisp/comp.el (comp-func): Fix doc for blocks slot. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index a7da7d42e9..d860fa31f0 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -368,8 +368,7 @@ Once in SSA form this *must* be set to 'dirty' every time the topology of the CFG is mutated by a pass.") (frame-size nil :type number) (blocks (make-hash-table) :type hash-table - :documentation "Key is the basic block symbol value is a comp-block -structure.") + :documentation "Basic block name -> basic block.") (lap-block (make-hash-table :test #'equal) :type hash-table :documentation "LAP lable -> LIMPLE basic block name.") (edges () :type list commit b8772e8b08fd269681f449fbe81172e2a2dad19f Author: Andrea Corallo Date: Sat Oct 10 14:31:03 2020 +0200 * Fix LIMPLE latch block name coloring in "*Native-compile-Log*" * lisp/emacs-lisp/comp.el (comp-limple-lock-keywords): Fix latch block name coloring. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 1c5a4975f2..a7da7d42e9 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -493,7 +493,7 @@ Assume allocation class 'd-default as default." (1 font-lock-variable-name-face)) (,(rx (group-n 1 (or "entry" (seq (or "entry_" "entry_fallback_" "bb_") - (1+ num))))) + (1+ num) (? "_latch"))))) (1 font-lock-constant-face)) (,(rx "(" (group-n 1 (1+ (or word "-")))) (1 font-lock-keyword-face))) commit 51f5e487b2840be8c4aa19c4b06973ee7eef5085 Author: Brian Leung Date: Sat Oct 10 09:06:56 2020 +0000 Various typo fixes in native compiler related files * lisp/emacs-lisp/comp.el (native-compiler-error-dyn-func) (comp-func, comp-func-l) (comp-func-d, comp-ensure-native-compiler, comp-type-hint-p) (comp-func-unique-in-cu-p, comp-alloc-class-to-container) (comp-limple-mode, comp-loop-insn-in-block) (comp-lex-byte-func-p, comp-c-func-name, comp-decrypt-arg-list) (comp-spill-lap-function, comp-intern-func-in-ctxt) (comp-spill-lap-function, comp-spill-lap, comp-emit-handler) (comp-prepare-args-for-top-level): Various typo fixes. * src/comp.c (Fcomp_el_to_eln_filename): Fix typo in error message. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index dbd4cef1fc..1c5a4975f2 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -222,7 +222,7 @@ Useful to hook into pass checkers.") "Limple operators use to call subrs.") (define-error 'native-compiler-error-dyn-func - "can't native compile a non lexical scoped function" + "can't native compile a non-lexically-scoped function" 'native-compiler-error) (define-error 'native-compiler-error-empty-byte "empty byte compiler output" @@ -355,7 +355,7 @@ into it.") (c-name nil :type string :documentation "The function name in the native world.") (byte-func nil - :documentation "Byte compiled version.") + :documentation "Byte-compiled version.") (doc nil :type string :documentation "Doc string.") (int-spec nil :type list @@ -388,12 +388,12 @@ structure.") :documentation "t if pure nil otherwise.")) (cl-defstruct (comp-func-l (:include comp-func)) - "Lexical scoped function." + "Lexically-scoped function." (args nil :type comp-args-base :documentation "Argument specification of the function")) (cl-defstruct (comp-func-d (:include comp-func)) - "Dynamic scoped function." + "Dynamically-scoped function." (lambda-list nil :type list :documentation "Original lambda-list.")) @@ -419,8 +419,8 @@ structure.") (defun comp-ensure-native-compiler () - "Make sure Emacs has native compiler support and libgccjit is laodable. -Raise and error otherwise. + "Make sure Emacs has native compiler support and libgccjit is loadable. +Raise an error otherwise. To be used by all entry points." (cond ((null (boundp 'comp-ctxt)) @@ -445,11 +445,11 @@ To be used by all entry points." (comp-call-op-p (car-safe insn))) (defsubst comp-type-hint-p (func) - "Type hint predicate for function name FUNC." + "Type-hint predicate for function name FUNC." (when (memq func comp-type-hints) t)) (defun comp-func-unique-in-cu-p (func) - "Return t if FUNC is know to be unique in the current compilation unit." + "Return t if FUNC is known to be unique in the current compilation unit." (if (symbolp func) (cl-loop with h = (make-hash-table :test #'eq) for f being the hash-value in (comp-ctxt-funcs-h comp-ctxt) @@ -473,8 +473,8 @@ To be used by all entry points." (comp-func-pure func)))) (defsubst comp-alloc-class-to-container (alloc-class) - "Given ALLOC-CLASS return the data container for the current context. -Assume allocaiton class 'd-default as default." + "Given ALLOC-CLASS, return the data container for the current context. +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) @@ -500,7 +500,7 @@ Assume allocaiton class 'd-default as default." "Highlights used by comp-limple-mode.") (define-derived-mode comp-limple-mode fundamental-mode "LIMPLE" - "Syntax highlight LIMPLE IR." + "Syntax-highlight LIMPLE IR." (setf font-lock-defaults '(comp-limple-lock-keywords))) (cl-defun comp-log (data &optional (level 1)) @@ -571,7 +571,7 @@ VERBOSITY is a number between 0 and 3." (defmacro comp-loop-insn-in-block (basic-block &rest body) - "Loop over all insns in BASIC-BLOCK executning BODY. + "Loop over all insns in BASIC-BLOCK executing BODY. Inside BODY `insn' can be used to read or set the current instruction." (declare (debug (form body)) @@ -584,7 +584,7 @@ instruction." ;;; spill-lap pass specific code. (defsubst comp-lex-byte-func-p (f) - "Return t if F is a lexical scoped byte compiled function." + "Return t if F is a lexically-scoped byte compiled function." (and (byte-code-function-p f) (fixnump (aref f 0)))) @@ -598,11 +598,11 @@ instruction." (or (comp-spill-decl-spec function-name 'speed) comp-speed)) -;; Autoloaded as might by used by `disassemble-internal'. +;; Autoloaded as might be used by `disassemble-internal'. ;;;###autoload (defun comp-c-func-name (name prefix &optional first) - "Given NAME return a name suitable for the native code. -Add PREFIX in front of it. If FIRST is not nil pick the first + "Given NAME, return a name suitable for the native code. +Add PREFIX in front of it. If FIRST is not nil, pick the first available name ignoring compilation context and potential name clashes." ;; Unfortunatelly not all symbol names are valid as C function names... @@ -633,7 +633,7 @@ clashes." (concat prefix crypted "_" human-readable "_0")))) (defun comp-decrypt-arg-list (x function-name) - "Decript argument list X for FUNCTION-NAME." + "Decrypt argument list X for FUNCTION-NAME." (unless (fixnump x) (signal 'native-compiler-error-dyn-func function-name)) (let ((rest (not (= (logand x 128) 0))) @@ -659,10 +659,10 @@ clashes." (puthash c-name func (comp-ctxt-funcs-h comp-ctxt)))) (cl-defgeneric comp-spill-lap-function (input) - "Byte compile INPUT and spill lap for further stages.") + "Byte-compile INPUT and spill lap for further stages.") (cl-defmethod comp-spill-lap-function ((function-name symbol)) - "Byte compile FUNCTION-NAME spilling data from the byte compiler." + "Byte-compile FUNCTION-NAME spilling data from the byte compiler." (let* ((f (symbol-function function-name)) (c-name (comp-c-func-name function-name "F")) (func (make-comp-func-l :name function-name @@ -697,7 +697,7 @@ clashes." (comp-add-func-to-ctxt func)))) (defun comp-intern-func-in-ctxt (_ obj) - "Given OBJ of type `byte-to-native-lambda' create a function in `comp-ctxt'." + "Given OBJ of type `byte-to-native-lambda', create a function in `comp-ctxt'." (when-let ((byte-func (byte-to-native-lambda-byte-func obj))) (let* ((lap (byte-to-native-lambda-lap obj)) (top-l-form (cl-loop @@ -737,7 +737,7 @@ clashes." (comp-log lap 1)))) (cl-defmethod comp-spill-lap-function ((filename string)) - "Byte compile FILENAME spilling data from the byte compiler." + "Byte-compile FILENAME spilling data from the byte compiler." (byte-compile-file filename) (unless byte-to-native-top-level-forms (signal 'native-compiler-error-empty-byte filename)) @@ -760,7 +760,7 @@ clashes." (maphash #'comp-intern-func-in-ctxt byte-to-native-lambdas-h)) (defun comp-spill-lap (input) - "Byte compile and spill the LAP representation for INPUT. + "Byte-compile and spill the LAP representation for INPUT. If INPUT is a symbol this is the function-name to be compiled. If INPUT is a string this is the file path to be compiled." (let ((byte-native-compiling t) @@ -993,7 +993,7 @@ Return value is the fall through block name." bb))) (defun comp-emit-handler (lap-label handler-type) - "Emit a non local exit handler to LAP-LABEL of type HANDLER-TYPE." + "Emit a nonlocal-exit handler to LAP-LABEL of type HANDLER-TYPE." (cl-destructuring-bind (label-num . label-sp) lap-label (cl-assert (= (- label-sp 2) (comp-sp))) (setf (comp-func-has-non-local comp-func) t) @@ -1405,10 +1405,10 @@ the annotation emission." func) (cl-defgeneric comp-prepare-args-for-top-level (function) - "Given FUNCTION return the two args arguments for comp--register-...") + "Given FUNCTION, return the two args arguments for comp--register-...") (cl-defmethod comp-prepare-args-for-top-level ((function comp-func-l)) - "Lexical scoped FUNCTION." + "Lexically-scoped FUNCTION." (let ((args (comp-func-l-args function))) (cons (make-comp-mvar :constant (comp-args-base-min args)) (make-comp-mvar :constant (if (comp-args-p args) diff --git a/src/comp.c b/src/comp.c index 1b96bffeb8..13343de3d8 100644 --- a/src/comp.c +++ b/src/comp.c @@ -4124,7 +4124,7 @@ If BASE-DIR is nil use the first entry in `comp-eln-load-path'. */) } if (NILP (base_dir)) error ("Cannot find suitable directory for output in " - "`comp-native-laod-path'."); + "`comp-native-load-path'."); } if (!file_name_absolute_p (SSDATA (base_dir))) commit f7e7ff4fb16bf8fc8e7662f21cd9843e9eb648e8 Merge: 138990bbda 5824c209ba Author: Andrea Corallo Date: Sat Oct 10 11:00:35 2020 +0200 Merge remote-tracking branch 'savannah/master' into HEAD commit 138990bbda7ab228e3fde44710426c474b2c1086 Author: Andrea Corallo Date: Sat Oct 10 10:15:21 2020 +0200 * Fix failure when compiling a trampoline with no eln-cache dir (bug#43875) * lisp/emacs-lisp/comp.el (comp-trampoline-compile): Try to create the eln-cache dir if this is not existing, if fails to do that move on to the next one. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 0445fc085e..dbd4cef1fc 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2603,11 +2603,15 @@ Return the its filename if found or nil otherwise." (native-compile trampoline-sym nil (cl-loop - for dir in comp-eln-load-path + for load-dir in comp-eln-load-path + for dir = (concat load-dir comp-native-version-dir) for f = (expand-file-name (comp-trampoline-filename subr-name) - (concat dir - comp-native-version-dir)) + dir) + unless (file-exists-p dir) + do (ignore-errors + (make-directory dir t) + (cl-return f)) when (file-writable-p f) do (cl-return f) finally (error "Cannot find suitable directory for output in \ commit 85450f03be6cbb3e09964ce62e1f63875f0848a3 Author: Andrew Whatson Date: Sat Oct 10 10:13:26 2020 +0200 * Fix typo name plus make error homogeneous in `comp-trampoline-compile' * lisp/emacs-lisp/comp.el (comp-trampoline-compile): Fix typo renaming `comp-tampoline-compile' -> `comp-trampoline-compile'. Change error to be consistent. (comp-subr-trampoline-install): Use `comp-trampoline-compile'. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 763d44a23e..0445fc085e 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2580,7 +2580,7 @@ Return the its filename if found or nil otherwise." when (file-exists-p filename) do (cl-return filename))) -(defun comp-tampoline-compile (subr-name) +(defun comp-trampoline-compile (subr-name) "Synthesize and compile a trampoline for SUBR-NAME and return its filename." (let ((trampoline-sym (comp-trampoline-sym subr-name)) (lambda-list (comp-make-lambda-list-from-subr @@ -2610,7 +2610,7 @@ Return the its filename if found or nil otherwise." comp-native-version-dir)) when (file-writable-p f) do (cl-return f) - finally (error "Can't find a writable directory in \ + finally (error "Cannot find suitable directory for output in \ `comp-eln-load-path'"))))) ;;;###autoload @@ -2621,7 +2621,7 @@ Return the its filename if found or nil otherwise." (let ((trampoline-sym (comp-trampoline-sym subr-name))) (cl-assert (subr-primitive-p (symbol-function subr-name))) (load (or (comp-search-trampoline subr-name) - (comp-tampoline-compile subr-name)) + (comp-trampoline-compile subr-name)) nil t) (cl-assert (subr-native-elisp-p (symbol-function trampoline-sym))) commit c3bc348f5edefa4231d38b6d3967f0c8f0bb5e6d Author: Andrea Corallo Date: Wed Oct 7 23:38:00 2020 +0200 * Fix failure when eln-cache is removed (introduced by 4a1bb46260) * src/comp.c (make_directory_wrapper, make_directory_wrapper_1): New functions. (Fcomp_el_to_eln_filename): If base_dir is not specified and we are searching across `comp-load-path' try to create a directory if does not exists. diff --git a/src/comp.c b/src/comp.c index ba4089e5ae..1b96bffeb8 100644 --- a/src/comp.c +++ b/src/comp.c @@ -4013,6 +4013,19 @@ compile_function (Lisp_Object func) /* In use by Fcomp_el_to_eln_filename. */ static Lisp_Object loadsearch_re_list; +static Lisp_Object +make_directory_wrapper (Lisp_Object directory) +{ + CALL2I (make-directory, directory, Qt); + return Qnil; +} + +static Lisp_Object +make_directory_wrapper_1 (Lisp_Object ignore) +{ + return Qt; +} + DEFUN ("comp-el-to-eln-filename", Fcomp_el_to_eln_filename, Scomp_el_to_eln_filename, 1, 2, 0, doc: /* Given a source FILENAME return the corresponding .eln filename. @@ -4087,14 +4100,31 @@ If BASE-DIR is nil use the first entry in `comp-eln-load-path'. */) { Lisp_Object eln_load_paths = Vcomp_eln_load_path; FOR_EACH_TAIL (eln_load_paths) - if (!NILP (Ffile_writable_p (XCAR (eln_load_paths)))) - { - base_dir = XCAR (eln_load_paths); - break; - } - /* If we can't find it return Nil. */ + { + Lisp_Object dir = XCAR (eln_load_paths); + if (!NILP (Ffile_exists_p (dir))) + { + if (!NILP (Ffile_writable_p (dir))) + { + base_dir = dir; + break; + } + } + else + { + /* Try to create the directory and if succeeds use it. */ + if (NILP (internal_condition_case_1 (make_directory_wrapper, + dir, Qt, + make_directory_wrapper_1))) + { + base_dir = dir; + break; + } + } + } if (NILP (base_dir)) - return Qnil; + error ("Cannot find suitable directory for output in " + "`comp-native-laod-path'."); } if (!file_name_absolute_p (SSDATA (base_dir))) commit 7041c32ec2cd985f1c324c75ecea8038f998a792 Author: Andrea Corallo Date: Wed Oct 7 20:43:00 2020 +0200 * Fix some nits in comp.el * lisp/emacs-lisp/comp.el (comp-spill-lap-function): Use `cl-defmethod' where correct in place of `cl-defgeneric'. (comp-tampoline-compile): Add missing #. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 01ffd4d40e..763d44a23e 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -661,7 +661,7 @@ clashes." (cl-defgeneric comp-spill-lap-function (input) "Byte compile INPUT and spill lap for further stages.") -(cl-defgeneric comp-spill-lap-function ((function-name symbol)) +(cl-defmethod comp-spill-lap-function ((function-name symbol)) "Byte compile FUNCTION-NAME spilling data from the byte compiler." (let* ((f (symbol-function function-name)) (c-name (comp-c-func-name function-name "F")) @@ -736,7 +736,7 @@ clashes." (comp-log (format "Function %s:\n" name) 1) (comp-log lap 1)))) -(cl-defgeneric comp-spill-lap-function ((filename string)) +(cl-defmethod comp-spill-lap-function ((filename string)) "Byte compile FILENAME spilling data from the byte compiler." (byte-compile-file filename) (unless byte-to-native-top-level-forms @@ -2594,7 +2594,7 @@ Return the its filename if found or nil otherwise." (defalias trampoline-sym `(closure nil ,lambda-list (let ((f #',subr-name)) - (,(if (memq '&rest lambda-list) 'apply 'funcall) + (,(if (memq '&rest lambda-list) #'apply 'funcall) f ,@(cl-loop for arg in lambda-list commit 58d85f4dbb878eca08c770b9de8f734ca78840db Author: Andrea Corallo Date: Wed Oct 7 07:41:00 2020 +0200 * Do use echo area for async compilation started/finished messages * lisp/emacs-lisp/comp.el (comp-run-async-workers) (native-compile-async): Do not write into the echo area. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 7074ff759e..01ffd4d40e 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2783,16 +2783,14 @@ display a message." when (>= (comp-async-runnings) (comp-effective-async-max-jobs)) do (cl-return))) ;; No files left to compile and all processes finished. - (let ((msg "Compilation finished.")) - (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"))) - ;; `comp-deferred-pending-h' should be empty at this stage. - ;; Reset it anyway. - (clrhash comp-deferred-pending-h) - (message msg)))) + (run-hooks 'comp-async-all-done-hook) + (with-current-buffer (get-buffer-create comp-async-buffer-name) + (save-excursion + (goto-char (point-max)) + (insert "Compilation finished.\n"))) + ;; `comp-deferred-pending-h' should be empty at this stage. + ;; Reset it anyway. + (clrhash comp-deferred-pending-h))) ;;; Compiler entry points. @@ -2928,8 +2926,7 @@ queued with LOAD %" (format "No write access for %s skipping." out-filename))))))) (when (zerop (comp-async-runnings)) - (comp-run-async-workers) - (message "Compilation started.")))) + (comp-run-async-workers)))) (provide 'comp) commit bd2725796578c67075711adc4c1be7c2bf684214 Author: Andrea Corallo Date: Wed Oct 7 08:40:00 2020 +0200 * Better libgccjit related error messaging during configure * configure.ac: Distinguish the case when libgccjit is missing, its headers are missing, or libgccjit is broken. Message the user based on that. diff --git a/configure.ac b/configure.ac index b7b0c268c8..100fbba06c 100644 --- a/configure.ac +++ b/configure.ac @@ -3779,15 +3779,25 @@ AC_DEFUN([libgccjit_smoke_test], [ AC_DEFUN([libgccjit_not_found], [ AC_MSG_ERROR([elisp native compiler requested but libgccjit not found. +Please try installing libgccjit or similar package. If you are sure you want Emacs compiled without elisp native compiler, pass --without-nativecomp to configure.])]) +AC_DEFUN([libgccjit_dev_not_found], [ + AC_MSG_ERROR([elisp native compiler requested but libgccjit header files were +not found. +Please try installing libgccjit-dev or similar package. +If you are sure you want Emacs compiled without elisp native compiler, pass +--without-nativecomp +to configure.])]) + AC_DEFUN([libgccjit_broken], [ AC_MSG_ERROR([Installed libgccjit has failed passing the smoke test. You can verify it yourself compiling: . -Please report the issue to your distribution. +Please report the issue to your distribution if libgccjit was installed through +that. Here instructions on how to compile and install libgccjit from source: .])]) @@ -3800,10 +3810,13 @@ if test "${with_nativecomp}" != "no"; then if test "${HAVE_ZLIB}" = no; then AC_MSG_ERROR(['--with-nativecomp' requires zlib]) fi + # Check if libgccjit is available. + AC_CHECK_LIB(gccjit, gcc_jit_context_acquire, [], [libgccjit_not_found]) + AC_CHECK_HEADERS(libgccjit.h, [], [libgccjit_dev_not_found]) emacs_save_LIBS=$LIBS LIBS="-lgccjit" - AC_RUN_IFELSE([libgccjit_smoke_test], [], [libgccjit_broken], - [AC_LINK_IFELSE([libgccjit_smoke_test], [], [libgccjit_not_found])]) + # Check if libgccjit really works. + AC_RUN_IFELSE([libgccjit_smoke_test], [], [libgccjit_broken]) LIBS=$emacs_save_LIBS HAVE_NATIVE_COMP=yes # mingw32 loads the library dynamically. commit 4a1bb4626053d5be5d3e869d6b7049dc3269d812 Author: Andrea Corallo Date: Tue Oct 6 17:44:13 2020 +0200 * Native compiling do not target a directory with no write permission * src/comp.c (Fcomp_el_to_eln_filename): Check for write permission while choosing the output directory in `comp-eln-load-path'. diff --git a/src/comp.c b/src/comp.c index 076236ef80..ba4089e5ae 100644 --- a/src/comp.c +++ b/src/comp.c @@ -4080,8 +4080,22 @@ If BASE-DIR is nil use the first entry in `comp-eln-load-path'. */) separator); Lisp_Object hash = concat3 (path_hash, separator, content_hash); filename = concat3 (filename, hash, build_string (NATIVE_ELISP_SUFFIX)); + + /* If base_dir was not specified search inside Vcomp_eln_load_path + for the first directory where we have write access. */ if (NILP (base_dir)) - base_dir = XCAR (Vcomp_eln_load_path); + { + Lisp_Object eln_load_paths = Vcomp_eln_load_path; + FOR_EACH_TAIL (eln_load_paths) + if (!NILP (Ffile_writable_p (XCAR (eln_load_paths)))) + { + base_dir = XCAR (eln_load_paths); + break; + } + /* If we can't find it return Nil. */ + if (NILP (base_dir)) + return Qnil; + } if (!file_name_absolute_p (SSDATA (base_dir))) base_dir = Fexpand_file_name (base_dir, Vinvocation_directory); commit 29f7024b6cfc01d6cae10603733b35784b4e4aef Author: Andrea Corallo Date: Sat Oct 3 21:33:08 2020 +0200 * Fix a test in test/lisp/subr-tests.el * test/lisp/subr-tests.el (subr-tests-bug22027): Redefine `read-string' with a lambda with the same number of arguments. diff --git a/test/lisp/subr-tests.el b/test/lisp/subr-tests.el index 035c064d75..c3dfd27a85 100644 --- a/test/lisp/subr-tests.el +++ b/test/lisp/subr-tests.el @@ -338,7 +338,7 @@ cf. Bug#25477." "Test for https://debbugs.gnu.org/22027 ." (let ((default "foo") res) (cl-letf (((symbol-function 'read-string) - (lambda (_prompt _init _hist def) def))) + (lambda (_prompt _init _hist def _inher-input) def))) (setq res (read-passwd "pass: " 'confirm (mapconcat #'string default ""))) (should (string= default res))))) commit f43dbe65ce14921aee2f45d21eb5f294ec8b92c1 Author: Andrea Corallo Date: Sat Oct 3 16:12:19 2020 +0200 Add a test for primitive redefinition * test/src/comp-tests.el (primitive-redefine): New test. * test/src/comp-test-funcs.el (comp-test-primitive-redefine-f): New function. diff --git a/test/src/comp-test-funcs.el b/test/src/comp-test-funcs.el index 19acec2716..9285ed62c2 100644 --- a/test/src/comp-test-funcs.el +++ b/test/src/comp-test-funcs.el @@ -341,6 +341,10 @@ (declare (speed 2)) (+ x y)) +(defun comp-test-primitive-redefine-f (x y) + (declare (speed 2)) + (- x y)) + ;;;;;;;;;;;;;;;;;;;; ;; Tromey's tests ;; diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index f954ae6a9d..317a6113af 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -398,6 +398,17 @@ https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-03/msg00914.html." (should (equal comp-test-primitive-advice '(3 4)))) (advice-remove #'+ f)))) +(defvar comp-test-primitive-redefine-args) +(comp-deftest primitive-redefine () + "Test effectiveness of primitve redefinition." + (cl-letf ((comp-test-primitive-redefine-args nil) + ((symbol-function #'-) + (lambda (&rest args) + (setq comp-test-primitive-redefine-args args) + 'xxx))) + (should (eq (comp-test-primitive-redefine-f 10 2) 'xxx)) + (should (equal comp-test-primitive-redefine-args '(10 2))))) + ;;;;;;;;;;;;;;;;;;;;; ;; Tromey's tests. ;; commit 87c6aa13b30281398688ec8693a0205bb84bc648 Author: Andrea Corallo Date: Fri Oct 2 22:36:05 2020 +0200 Make primitive redefinition effective through trampoline synthesis * lisp/loadup.el (dump-mode): Set `comp-enable-subr-trampolines' when finished bootstrap. * src/data.c (Ffset): Call `comp-enable-subr-trampolines' when redefining a subr. * src/comp.c (syms_of_comp): Define `comp-subr-trampoline-install' symbol. (syms_of_comp): Define `comp-enable-subr-trampolines' variable. diff --git a/lisp/loadup.el b/lisp/loadup.el index f218ec1ff9..91126703d1 100644 --- a/lisp/loadup.el +++ b/lisp/loadup.el @@ -510,6 +510,11 @@ lost after dumping"))) ((equal dump-mode "bootstrap") "emacs") ((equal dump-mode "pbootstrap") "bootstrap-emacs.pdmp") (t (error "unrecognized dump mode %s" dump-mode))))) + (when (and (boundp 'comp-ctxt) + (equal dump-mode "pdump")) + ;; Don't enable this before bootstrap is completed the as the + ;; compiler infrastructure may not be usable. + (setq comp-enable-subr-trampolines t)) (message "Dumping under the name %s" output) (condition-case () (delete-file output) diff --git a/src/comp.c b/src/comp.c index 5663c9e562..076236ef80 100644 --- a/src/comp.c +++ b/src/comp.c @@ -5141,6 +5141,7 @@ native compiled one. */); DEFSYM (Qlate, "late"); DEFSYM (Qlambda_fixup, "lambda-fixup"); DEFSYM (Qgccjit, "gccjit"); + DEFSYM (Qcomp_subr_trampoline_install, "comp-subr-trampoline-install") /* To be signaled by the compiler. */ DEFSYM (Qnative_compiler_error, "native-compiler-error"); @@ -5246,6 +5247,11 @@ The last directory of this list is assumed to be the system one. */); dump reload. */ Vcomp_eln_load_path = Fcons (build_string ("../native-lisp/"), Qnil); + DEFVAR_BOOL ("comp-enable-subr-trampolines", comp_enable_subr_trampolines, + doc: /* When non-nil enable trampoline synthesis + triggerd by `fset' making primitives + redefinable effectivelly. */); + DEFVAR_LISP ("comp-installed-trampolines-h", Vcomp_installed_trampolines_h, doc: /* Hash table subr-name -> bool. */); Vcomp_installed_trampolines_h = CALLN (Fmake_hash_table); diff --git a/src/data.c b/src/data.c index 8c39c31911..c6629dd5f2 100644 --- a/src/data.c +++ b/src/data.c @@ -775,6 +775,13 @@ DEFUN ("fset", Ffset, Sfset, 2, 2, 0, eassert (valid_lisp_object_p (definition)); +#ifdef HAVE_NATIVE_COMP + if (comp_enable_subr_trampolines + && SUBRP (function) + && !SUBR_NATIVE_COMPILEDP (function)) + CALLN (Ffuncall, Qcomp_subr_trampoline_install, symbol); +#endif + set_symbol_function (symbol, definition); return definition; commit 0b58be4941c92d337eccadabaaba5ef8620c5b52 Author: Andrea Corallo Date: Fri Oct 2 22:18:57 2020 +0200 Rename comp-subr-safe-advice -> comp-subr-trampoline-install diff --git a/lisp/emacs-lisp/advice.el b/lisp/emacs-lisp/advice.el index 4df8743de5..fb67de3a02 100644 --- a/lisp/emacs-lisp/advice.el +++ b/lisp/emacs-lisp/advice.el @@ -2076,7 +2076,7 @@ If FUNCTION was not advised already, its advice info will be initialized. Redefining a piece of advice whose name is part of the cache-id will clear the cache." (when (subr-primitive-p (symbol-function function)) - (comp-subr-safe-advice function)) + (comp-subr-trampoline-install function)) (cond ((not (ad-is-advised function)) (ad-initialize-advice-info function) (ad-set-advice-info-field diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index ef13c0ce63..7074ff759e 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2614,7 +2614,7 @@ Return the its filename if found or nil otherwise." `comp-eln-load-path'"))))) ;;;###autoload -(defun comp-subr-safe-advice (subr-name) +(defun comp-subr-trampoline-install (subr-name) "Make SUBR-NAME effectively advice-able when called from native code." (unless (or (memq subr-name comp-never-optimize-functions) (gethash subr-name comp-installed-trampolines-h)) diff --git a/lisp/emacs-lisp/nadvice.el b/lisp/emacs-lisp/nadvice.el index 5b3aa70850..0396132585 100644 --- a/lisp/emacs-lisp/nadvice.el +++ b/lisp/emacs-lisp/nadvice.el @@ -333,7 +333,7 @@ is also interactive. There are 3 cases: ;; Must require explicitly as during bootstrap we have no ;; autoloads. (require 'comp) - (comp-subr-safe-advice subr-name)))) + (comp-subr-trampoline-install subr-name)))) (let* ((name (cdr (assq 'name props))) (a (advice--member-p (or name function) (if name t) (gv-deref ref)))) (when a commit b3ade4de179d4c13cd09e2b8066e09c66355d322 Author: Andrea Corallo Date: Sun Oct 4 20:09:04 2020 +0200 Revert "Use `advice-flet' in place of `cl-letf' to avoid primitive... This reverts commit 825e85b393a3d78ba43176ecc5bc1a9595d0fbea. diff --git a/test/lisp/abbrev-tests.el b/test/lisp/abbrev-tests.el index 9b998add23..aaf1d4a5b5 100644 --- a/test/lisp/abbrev-tests.el +++ b/test/lisp/abbrev-tests.el @@ -279,7 +279,7 @@ (let ((table (make-abbrev-table))) (with-temp-buffer (insert "some text foo ") - (advice-flet ((read-string (lambda (&rest _) "bar"))) + (cl-letf (((symbol-function 'read-string) (lambda (&rest _) "bar"))) (inverse-add-abbrev table "Global" 1))) (should (string= (abbrev-expansion "foo" table) "bar")))) @@ -288,7 +288,7 @@ (let ((table (make-abbrev-table))) (with-temp-buffer (insert "some text foo ") - (advice-flet ((read-string (lambda (&rest _) "bar"))) + (cl-letf (((symbol-function 'read-string) (lambda (&rest _) "bar"))) (inverse-add-abbrev table "Global" 2))) (should (string= (abbrev-expansion "text" table) "bar")))) @@ -298,7 +298,7 @@ (with-temp-buffer (insert "some text foo") (goto-char (point-min)) - (advice-flet ((read-string (lambda (&rest _) "bar"))) + (cl-letf (((symbol-function 'read-string) (lambda (&rest _) "bar"))) (inverse-add-abbrev table "Global" -1))) (should (string= (abbrev-expansion "text" table) "bar")))) diff --git a/test/lisp/bookmark-tests.el b/test/lisp/bookmark-tests.el index 26d75ce0c4..c5959e46d8 100644 --- a/test/lisp/bookmark-tests.el +++ b/test/lisp/bookmark-tests.el @@ -633,9 +633,9 @@ testing `bookmark-bmenu-list'." (ert-deftest bookmark-test-bmenu-locate () (let (msg) - (advice-flet ((message - (lambda (&rest args) - (setq msg (apply #'format args))))) + (cl-letf (((symbol-function 'message) + (lambda (&rest args) + (setq msg (apply #'format args))))) (with-bookmark-bmenu-test (bookmark-bmenu-locate) (should (equal msg "/some/file")))))) diff --git a/test/lisp/emacs-lisp/rmc-tests.el b/test/lisp/emacs-lisp/rmc-tests.el index de6db13347..5add24c479 100644 --- a/test/lisp/emacs-lisp/rmc-tests.el +++ b/test/lisp/emacs-lisp/rmc-tests.el @@ -33,12 +33,10 @@ (ert-deftest test-read-multiple-choice () (dolist (char '(?y ?n)) - (let ((str (if (eq char ?y) "yes" "no"))) - (advice-flet ((read-event - (lambda () char))) - (should (equal (list char str) - (read-multiple-choice "Do it? " - '((?y "yes") (?n "no"))))))))) + (cl-letf* (((symbol-function #'read-event) (lambda () char)) + (str (if (eq char ?y) "yes" "no"))) + (should (equal (list char str) + (read-multiple-choice "Do it? " '((?y "yes") (?n "no")))))))) (provide 'rmc-tests) diff --git a/test/lisp/files-tests.el b/test/lisp/files-tests.el index 3829f50501..1b964af688 100644 --- a/test/lisp/files-tests.el +++ b/test/lisp/files-tests.el @@ -242,25 +242,24 @@ form.") "Test file prompting in directory named `~'. If we are in a directory named `~', the default value should not be $HOME." - (let* ((dir (make-temp-file "read-file-name-test" t)) - (subdir (expand-file-name "./~/" dir))) - (advice-flet ((completing-read - (lambda (_prompt _coll &optional _pred _req init _hist def _) - (or def init)))) - (unwind-protect - (progn - (make-directory subdir t) - (with-temp-buffer - (setq default-directory subdir) - (should-not (equal - (expand-file-name (read-file-name "File: ")) - (expand-file-name "~/"))) - ;; Don't overquote either! - (setq default-directory (concat "/:" subdir)) - (should-not (equal - (expand-file-name (read-file-name "File: ")) - (concat "/:/:" subdir))))) - (delete-directory dir 'recursive))))) + (cl-letf (((symbol-function 'completing-read) + (lambda (_prompt _coll &optional _pred _req init _hist def _) + (or def init))) + (dir (make-temp-file "read-file-name-test" t))) + (unwind-protect + (let ((subdir (expand-file-name "./~/" dir))) + (make-directory subdir t) + (with-temp-buffer + (setq default-directory subdir) + (should-not (equal + (expand-file-name (read-file-name "File: ")) + (expand-file-name "~/"))) + ;; Don't overquote either! + (setq default-directory (concat "/:" subdir)) + (should-not (equal + (expand-file-name (read-file-name "File: ")) + (concat "/:/:" subdir))))) + (delete-directory dir 'recursive)))) (ert-deftest files-tests-file-name-non-special-quote-unquote () (let (;; Just in case it is quoted, who knows. diff --git a/test/lisp/kmacro-tests.el b/test/lisp/kmacro-tests.el index cc0f48eee8..bb18c82814 100644 --- a/test/lisp/kmacro-tests.el +++ b/test/lisp/kmacro-tests.el @@ -341,8 +341,8 @@ This is a regression test for: Bug#3412, Bug#11817." (message "") ; Clear the echo area. (Bug#3412) (kmacro-tests-should-match-message "Type e to repeat macro" (kmacro-tests-should-insert "mmmmmm" - (advice-flet ((this-single-command-keys (lambda () - [?\C-x ?e]))) + (cl-letf (((symbol-function #'this-single-command-keys) (lambda () + [?\C-x ?e]))) (kmacro-call-macro 3)) ;; Check that it set up for repeat, and run the repeat. (funcall (lookup-key overriding-terminal-local-map "e")))))) @@ -455,8 +455,8 @@ This is a regression test for: Bug#3412, Bug#11817." ;; commands so it should end the sequence. (let* ((end-key (kmacro-tests-get-kmacro-key 'kmacro-set-counter)) (kmacro-tests-events (append events (list end-key)))) - (advice-flet ((this-single-command-keys - (lambda () first-event))) + (cl-letf (((symbol-function #'this-single-command-keys) + (lambda () first-event))) (use-local-map kmacro-tests-keymap) (kmacro-tests-should-insert "ccbacb" ;; End #3 and launch loop to read events. @@ -466,9 +466,9 @@ This is a regression test for: Bug#3412, Bug#11817." ;; so run it again with that at the end. (let* ((end-key (kmacro-tests-get-kmacro-key 'kmacro-edit-macro-repeat)) (kmacro-tests-events (append events (list end-key)))) - (advice-flet ((edit-kbd-macro #'ignore) - (this-single-command-keys - (lambda () first-event))) + (cl-letf (((symbol-function #'edit-kbd-macro) #'ignore) + ((symbol-function #'this-single-command-keys) + (lambda () first-event))) (use-local-map kmacro-tests-keymap) (kmacro-tests-should-insert "bbbbbaaba" (kmacro-end-or-call-macro-repeat 3))))))) @@ -494,22 +494,20 @@ This is a regression test for: Bug#3412, Bug#11817." '("d" "c" "b" "a" "d" "c"))))) (cl-letf ((kmacro-repeat-no-prefix t) (kmacro-call-repeat-key t) - (kmacro-call-repeat-with-arg nil)) - (advice-flet ((this-single-command-keys (lambda () - first-event))) - ;; "Record" some macros. - (dotimes (n 4) - (kmacro-tests-define-macro (make-vector 1 (+ ?a n)))) - - (use-local-map kmacro-tests-keymap) - ;; 6 views (the direct call plus the 5 in events) should - ;; cycle through the ring and get to the second-to-last - ;; macro defined. - (kmacro-tests-should-insert - "c" - (kmacro-tests-should-match-message - macros-regexp - (kmacro-tests-simulate-command '(kmacro-view-macro-repeat nil)))))))) + (kmacro-call-repeat-with-arg nil) + ((symbol-function #'this-single-command-keys) (lambda () + first-event))) + ;; "Record" some macros. + (dotimes (n 4) + (kmacro-tests-define-macro (make-vector 1 (+ ?a n)))) + + (use-local-map kmacro-tests-keymap) + ;; 6 views (the direct call plus the 5 in events) should + ;; cycle through the ring and get to the second-to-last + ;; macro defined. + (kmacro-tests-should-insert "c" + (kmacro-tests-should-match-message macros-regexp + (kmacro-tests-simulate-command '(kmacro-view-macro-repeat nil))))))) (kmacro-tests-deftest kmacro-tests-bind-to-key-when-recording () "Bind to key doesn't bind a key during macro recording." @@ -544,18 +542,18 @@ This is a regression test for: Bug#3412, Bug#11817." (define-key map "\C-hi" 'info) (use-local-map map) ;; Try the command with yes-or-no-p set up to say no. - (advice-flet ((yes-or-no-p - (lambda (prompt) - (should (string-match-p "info" prompt)) - (should (string-match-p "C-h i" prompt)) - nil))) + (cl-letf (((symbol-function #'yes-or-no-p) + (lambda (prompt) + (should (string-match-p "info" prompt)) + (should (string-match-p "C-h i" prompt)) + nil))) (kmacro-bind-to-key nil)) (should (equal (where-is-internal 'info nil t) (vconcat "\C-hi"))) ;; Try it again with yes. - (advice-flet ((yes-or-no-p - (lambda (_prompt) t))) + (cl-letf (((symbol-function #' yes-or-no-p) + (lambda (_prompt) t))) (kmacro-bind-to-key nil)) (should-not (equal (where-is-internal 'info global-map t) diff --git a/test/lisp/net/tramp-tests.el b/test/lisp/net/tramp-tests.el index 0e4fcb5951..3914f9ae44 100644 --- a/test/lisp/net/tramp-tests.el +++ b/test/lisp/net/tramp-tests.el @@ -2420,16 +2420,16 @@ This checks also `file-name-as-directory', `file-name-directory', tramp--test-messages)))))))) ;; Do not overwrite if excluded. - (advice-flet ((y-or-n-p (lambda (_prompt) t)) - ;; Ange-FTP. - (yes-or-no-p (lambda (_prompt) t))) + (cl-letf (((symbol-function #'y-or-n-p) (lambda (_prompt) t)) + ;; Ange-FTP. + ((symbol-function 'yes-or-no-p) (lambda (_prompt) t))) (write-region "foo" nil tmp-name nil nil nil 'mustbenew)) ;; `mustbenew' is passed to Tramp since Emacs 26.1. (when (tramp--test-emacs26-p) (should-error - (advice-flet ((y-or-n-p #'ignore) - ;; Ange-FTP. - (yes-or-no-p 'ignore)) + (cl-letf (((symbol-function #'y-or-n-p) #'ignore) + ;; Ange-FTP. + ((symbol-function 'yes-or-no-p) 'ignore)) (write-region "foo" nil tmp-name nil nil nil 'mustbenew)) :type 'file-already-exists) (should-error @@ -3522,11 +3522,11 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." :type 'file-already-exists)) (when (tramp--test-expensive-test) ;; A number means interactive case. - (advice-flet ((yes-or-no-p #'ignore)) + (cl-letf (((symbol-function #'yes-or-no-p) #'ignore)) (should-error (make-symbolic-link tmp-name1 tmp-name2 0) :type 'file-already-exists))) - (advice-flet ((yes-or-no-p (lambda (_prompt) t))) + (cl-letf (((symbol-function #'yes-or-no-p) (lambda (_prompt) t))) (make-symbolic-link tmp-name1 tmp-name2 0) (should (string-equal @@ -3598,11 +3598,11 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (add-name-to-file tmp-name1 tmp-name2) :type 'file-already-exists) ;; A number means interactive case. - (advice-flet ((yes-or-no-p #'ignore)) + (cl-letf (((symbol-function #'yes-or-no-p) #'ignore)) (should-error (add-name-to-file tmp-name1 tmp-name2 0) :type 'file-already-exists)) - (advice-flet ((yes-or-no-p (lambda (_prompt) t))) + (cl-letf (((symbol-function #'yes-or-no-p) (lambda (_prompt) t))) (add-name-to-file tmp-name1 tmp-name2 0) (should (file-regular-p tmp-name2))) (add-name-to-file tmp-name1 tmp-name2 'ok-if-already-exists) diff --git a/test/lisp/play/dissociate-tests.el b/test/lisp/play/dissociate-tests.el index 1583a51acd..e8d903109f 100644 --- a/test/lisp/play/dissociate-tests.el +++ b/test/lisp/play/dissociate-tests.el @@ -25,8 +25,8 @@ (require 'dissociate) (ert-deftest dissociate-tests-dissociated-press () - (advice-flet ((y-or-n-p (lambda (_) nil)) - (random (lambda (_) 10))) + (cl-letf (((symbol-function 'y-or-n-p) (lambda (_) nil)) + ((symbol-function 'random) (lambda (_) 10))) (save-window-excursion (with-temp-buffer (insert "Lorem ipsum dolor sit amet") diff --git a/test/lisp/replace-tests.el b/test/lisp/replace-tests.el index 0f8084704d..aed14c3357 100644 --- a/test/lisp/replace-tests.el +++ b/test/lisp/replace-tests.el @@ -443,28 +443,29 @@ Return the last evalled form in BODY." ;; Bind `read-event' to simulate user input. ;; If `replace-tests-bind-read-string' is non-nil, then ;; bind `read-string' as well. - (advice-flet ((read-event - (lambda (&rest _args) - (cl-incf ,count) - (pcase ,count ; Build the clauses from CHAR-NUMS - ,@(append - (delq nil - (mapcar - (lambda (chr) - (when-let (it (alist-get chr char-nums)) - (if (cdr it) - `(,(cons 'or it) ,chr) - `(,(car it) ,chr)))) - '(?, ?\s ?u ?U ?E ?q))) - `((_ ,def-chr)))))) - (read-string - (if replace-tests-bind-read-string - (lambda (&rest _args) replace-tests-bind-read-string) - (lambda (&rest args) - (apply #'read-string args)))) - (replace-highlight - (lambda (&rest _args) - (string-match "[A-Z ]" "ForestGreen")))) + (cl-letf (((symbol-function 'read-event) + (lambda (&rest _args) + (cl-incf ,count) + (pcase ,count ; Build the clauses from CHAR-NUMS + ,@(append + (delq nil + (mapcar + (lambda (chr) + (when-let (it (alist-get chr char-nums)) + (if (cdr it) + `(,(cons 'or it) ,chr) + `(,(car it) ,chr)))) + '(?, ?\s ?u ?U ?E ?q))) + `((_ ,def-chr)))))) + ((symbol-function 'read-string) + (if replace-tests-bind-read-string + (lambda (&rest _args) replace-tests-bind-read-string) + (symbol-function 'read-string))) + ;; Emulate replace-highlight clobbering match-data via + ;; isearch-lazy-highlight-new-loop and sit-for (bug#36328) + ((symbol-function 'replace-highlight) + (lambda (&rest _args) + (string-match "[A-Z ]" "ForestGreen")))) (perform-replace ,from ,to t replace-tests-perform-replace-regexp-flag nil)) ,@body)))) diff --git a/test/lisp/shadowfile-tests.el b/test/lisp/shadowfile-tests.el index 6a9664638f..f40f6a1cdb 100644 --- a/test/lisp/shadowfile-tests.el +++ b/test/lisp/shadowfile-tests.el @@ -138,10 +138,10 @@ guaranteed by the originator of a cluster definition." (unwind-protect ;; We must mock `read-from-minibuffer' and `read-string', in ;; order to avoid interactive arguments. - (advice-flet ((read-from-minibuffer - (lambda (&rest _args) (pop mocked-input))) - (read-string - (lambda (&rest _args) (pop mocked-input)))) + (cl-letf* (((symbol-function #'read-from-minibuffer) + (lambda (&rest _args) (pop mocked-input))) + ((symbol-function #'read-string) + (lambda (&rest _args) (pop mocked-input)))) ;; Cleanup & initialize. (shadow--tests-cleanup) @@ -255,10 +255,10 @@ guaranteed by the originator of a cluster definition." (unwind-protect ;; We must mock `read-from-minibuffer' and `read-string', in ;; order to avoid interactive arguments. - (advice-flet ((read-from-minibuffer - (lambda (&rest _args) (pop mocked-input))) - (read-string - (lambda (&rest _args) (pop mocked-input)))) + (cl-letf* (((symbol-function #'read-from-minibuffer) + (lambda (&rest _args) (pop mocked-input))) + ((symbol-function #'read-string) + (lambda (&rest _args) (pop mocked-input)))) ;; Cleanup & initialize. (shadow--tests-cleanup) @@ -608,10 +608,10 @@ guaranteed by the originator of a cluster definition." (unwind-protect ;; We must mock `read-from-minibuffer' and `read-string', in ;; order to avoid interactive arguments. - (advice-flet ((read-from-minibuffer - (lambda (&rest _args) (pop mocked-input))) - (read-string - (lambda (&rest _args) (pop mocked-input)))) + (cl-letf* (((symbol-function #'read-from-minibuffer) + (lambda (&rest _args) (pop mocked-input))) + ((symbol-function #'read-string) + (lambda (&rest _args) (pop mocked-input)))) ;; Cleanup & initialize. (shadow--tests-cleanup) @@ -669,10 +669,10 @@ guaranteed by the originator of a cluster definition." (unwind-protect ;; We must mock `read-from-minibuffer' and `read-string', in ;; order to avoid interactive arguments. - (advice-flet ((read-from-minibuffer - (lambda (&rest _args) (pop mocked-input))) - (read-string - (lambda (&rest _args) (pop mocked-input)))) + (cl-letf* (((symbol-function #'read-from-minibuffer) + (lambda (&rest _args) (pop mocked-input))) + ((symbol-function #'read-string) + (lambda (&rest _args) (pop mocked-input)))) ;; Cleanup & initialize. (shadow--tests-cleanup) diff --git a/test/lisp/subr-tests.el b/test/lisp/subr-tests.el index b131b50935..035c064d75 100644 --- a/test/lisp/subr-tests.el +++ b/test/lisp/subr-tests.el @@ -337,8 +337,8 @@ cf. Bug#25477." (ert-deftest subr-tests-bug22027 () "Test for https://debbugs.gnu.org/22027 ." (let ((default "foo") res) - (advice-flet ((read-string - (lambda (_prompt _init _hist def) def))) + (cl-letf (((symbol-function 'read-string) + (lambda (_prompt _init _hist def) def))) (setq res (read-passwd "pass: " 'confirm (mapconcat #'string default ""))) (should (string= default res))))) diff --git a/test/lisp/tempo-tests.el b/test/lisp/tempo-tests.el index 333abffc84..bfe475910d 100644 --- a/test/lisp/tempo-tests.el +++ b/test/lisp/tempo-tests.el @@ -55,7 +55,7 @@ (with-temp-buffer (tempo-define-template "test" '("hello " (p ">"))) (let ((tempo-interactive t)) - (advice-flet ((read-string (lambda (&rest _) "world"))) + (cl-letf (((symbol-function 'read-string) (lambda (&rest _) "world"))) (tempo-insert-template 'tempo-template-test nil)) (should (equal (buffer-string) "hello world"))))) @@ -64,7 +64,7 @@ (with-temp-buffer (tempo-define-template "test" '("hello " (P ">"))) ;; By default, `tempo-interactive' is nil, `P' should ignore this. - (advice-flet ((read-string (lambda (&rest _) "world"))) + (cl-letf (((symbol-function 'read-string) (lambda (&rest _) "world"))) (tempo-insert-template 'tempo-template-test nil)) (should (equal (buffer-string) "hello world")))) @@ -73,7 +73,7 @@ (with-temp-buffer (tempo-define-template "test" '("abcde" (r ">") "ghijk")) (let ((tempo-interactive t)) - (advice-flet ((read-string (lambda (&rest _) "F"))) + (cl-letf (((symbol-function 'read-string) (lambda (&rest _) "F"))) (tempo-insert-template 'tempo-template-test nil)) (should (equal (buffer-string) "abcdeFghijk"))))) @@ -82,7 +82,7 @@ (with-temp-buffer (tempo-define-template "test" '("hello " (p ">" P1) " " (s P1))) (let ((tempo-interactive t)) - (advice-flet ((read-string (lambda (&rest _) "world!"))) + (cl-letf (((symbol-function 'read-string) (lambda (&rest _) "world!"))) (tempo-insert-template 'tempo-template-test nil)) (should (equal (buffer-string) "hello world! world!"))))) @@ -164,7 +164,7 @@ ;; Test interactive use (emacs-lisp-mode) (let ((tempo-interactive t)) - (advice-flet ((read-string (lambda (&rest _) " (list 1 2 3)"))) + (cl-letf (((symbol-function 'read-string) (lambda (&rest _) " (list 1 2 3)"))) (tempo-insert-template 'tempo-template-test nil)) (should (equal (buffer-string) "(progn\n (list 1 2 3))"))))) diff --git a/test/lisp/time-stamp-tests.el b/test/lisp/time-stamp-tests.el index ab662ffd95..e75e84b022 100644 --- a/test/lisp/time-stamp-tests.el +++ b/test/lisp/time-stamp-tests.el @@ -57,8 +57,8 @@ (defmacro with-time-stamp-system-name (name &rest body) "Force (system-name) to return NAME while evaluating BODY." (declare (indent defun)) - `(advice-flet ((system-name - (lambda () ,name))) + `(cl-letf (((symbol-function 'system-name) + (lambda () ,name))) ,@body)) (defmacro time-stamp-should-warn (form) commit ad5a2bbde071138cacadd19b95f2638741fd5d8d Author: Andrea Corallo Date: Fri Oct 2 22:17:09 2020 +0200 Revert "Add `advice-flet' macro" This reverts commit d07d7ab1a0e321ced62ebe5dd9db27eb7e93430e. diff --git a/lisp/emacs-lisp/nadvice.el b/lisp/emacs-lisp/nadvice.el index 21da038dc1..5b3aa70850 100644 --- a/lisp/emacs-lisp/nadvice.el +++ b/lisp/emacs-lisp/nadvice.el @@ -356,32 +356,6 @@ of the piece of advice." (macroexp-let2 nil new `(advice--remove-function ,getter ,function) `(unless (eq ,new ,getter) ,(funcall setter new))))) -;;;###autoload -(defmacro advice-flet (bindings &rest body) - ;; FIXME add doc. - (declare (indent 1)) - (let ((let-binds ()) - (ad-add ()) - (ad-del ())) - (dolist (bind bindings) - (let* ((fun-name (car bind)) - (fun (cadr bind)) - (tmp-sym (gensym (symbol-name fun-name)))) - (push `(,tmp-sym ,fun) let-binds) - (push `(advice-add #',fun-name - ,(if (= (length bind) 3) - (nth 2 bind) - :override) - ,tmp-sym) - ad-add) - (push `(advice-remove #',fun-name ,tmp-sym) ad-del))) - `(let ,(reverse let-binds) - (unwind-protect - (progn - ,@(reverse ad-add) - ,@body) - ,@(reverse ad-del))))) - (defun advice-function-mapc (f function-def) "Apply F to every advice function in FUNCTION-DEF. F is called with two arguments: the function that was added, and the commit 323200044f0c3f716f8f78a6f5e39349fe039117 Author: Andrea Corallo Date: Mon Oct 5 08:42:12 2020 +0200 * configure.ac (lispdirrel): Fix value for MacOS build. diff --git a/configure.ac b/configure.ac index be53578239..b7b0c268c8 100644 --- a/configure.ac +++ b/configure.ac @@ -1906,11 +1906,11 @@ if test "${with_ns}" != no; then # so avoid NS_IMPL_COCOA if macuvs.h is absent. # Even a headless Emacs can build macuvs.h, so this should let you bootstrap. if test "${opsys}" = darwin && test -f "$srcdir/src/macuvs.h"; then + lispdirrel=Contents/Resources/lisp NS_IMPL_COCOA=yes ns_appdir=`pwd`/nextstep/Emacs.app ns_appbindir=${ns_appdir}/Contents/MacOS - lispdirrel=Contents/Resources - ns_appresdir=${ns_appdir}/${lispdirrel} + ns_appresdir=${ns_appdir}/Contents/Resources ns_appsrc=Cocoa/Emacs.base ns_fontfile=macfont.o elif flags=$( (gnustep-config --objc-flags) 2>/dev/null); then commit 915214ac9a97025c01ec0bf1375d3630b3f6adf0 Author: Andrea Corallo Date: Sun Oct 4 22:48:37 2020 +0200 * configure.ac : Fix typo for MacOS nativecomp introduced by afb765ab3c diff --git a/configure.ac b/configure.ac index 5aceac6d95..be53578239 100644 --- a/configure.ac +++ b/configure.ac @@ -1910,7 +1910,7 @@ if test "${with_ns}" != no; then ns_appdir=`pwd`/nextstep/Emacs.app ns_appbindir=${ns_appdir}/Contents/MacOS lispdirrel=Contents/Resources - ns_appresdir=${ns_appdir}/{lispdirrel} + ns_appresdir=${ns_appdir}/${lispdirrel} ns_appsrc=Cocoa/Emacs.base ns_fontfile=macfont.o elif flags=$( (gnustep-config --objc-flags) 2>/dev/null); then commit 44ef24342fd8a2ac876212124ebf38673acda35a Merge: afb765ab3c d8665e6d34 Author: Andrea Corallo Date: Sun Oct 4 19:45:05 2020 +0200 Merge remote-tracking branch 'savannah/master' into HEAD commit afb765ab3cab7b6582d0def543b23603cd076445 Author: Andrea Corallo Date: Sun Oct 4 09:16:24 2020 +0200 Make filename hashing compatible with self contained builds (bug#43532) * Makefile.in (lispdirrel): Add replace template. (epaths-force): Form correctly 'PATH_REL_LOADSEARCH' into epath.h * configure.ac (lispdirrel): Define variable (relative path of the lisp files from the installation directory). * src/comp.c (Fcomp_el_to_eln_filename): Update algorithm not to rely on 'PATH_DUMPLOADSEARCH' but on 'PATH_REL_LOADSEARCH'. * src/epaths.in (PATH_REL_LOADSEARCH): Add macro template. diff --git a/Makefile.in b/Makefile.in index 2b47762b7b..027dca0bd7 100644 --- a/Makefile.in +++ b/Makefile.in @@ -223,6 +223,10 @@ iconsrcdir=$(srcdir)/etc/images/icons # These variables hold the values Emacs will actually use. They are # based on the values of the standard Make variables above. +# Where lisp files are installed in a distributed with Emacs (relative +# path to the installation directory). +lispdirrel=@lispdirrel@ + # Where to install the lisp files distributed with Emacs. # This includes the Emacs version, so that the lisp files for different # versions of Emacs will install themselves in separate directories. @@ -368,6 +372,7 @@ epaths-force: @(gamedir='${gamedir}'; \ sed < ${srcdir}/src/epaths.in > epaths.h.$$$$ \ -e 's;\(#.*PATH_LOADSEARCH\).*$$;\1 "${standardlisppath}";' \ + -e 's;\(#.*PATH_REL_LOADSEARCH\).*$$;\1 "${lispdirrel}";' \ -e 's;\(#.*PATH_SITELOADSEARCH\).*$$;\1 "${locallisppath}";' \ -e 's;\(#.*PATH_DUMPLOADSEARCH\).*$$;\1 "${buildlisppath}";' \ -e '/^#define PATH_[^ ]*SEARCH /s/\([":]\):*/\1/g' \ diff --git a/configure.ac b/configure.ac index 3d24751c93..ead27d3dea 100644 --- a/configure.ac +++ b/configure.ac @@ -187,7 +187,8 @@ dnl It is important that variables on the RHS not be expanded here, dnl hence the single quotes. This is per the GNU coding standards, see dnl (autoconf) Installation Directory Variables dnl See also epaths.h below. -lispdir='${datadir}/emacs/${version}/lisp' +lispdirrel='${version}/lisp' +lispdir='${datadir}/emacs/'${lispdirrel} standardlisppath='${lispdir}' locallisppath='${datadir}/emacs/${version}/site-lisp:'\ '${datadir}/emacs/site-lisp' @@ -1908,7 +1909,8 @@ if test "${with_ns}" != no; then NS_IMPL_COCOA=yes ns_appdir=`pwd`/nextstep/Emacs.app ns_appbindir=${ns_appdir}/Contents/MacOS - ns_appresdir=${ns_appdir}/Contents/Resources + lispdirrel=Contents/Resources + ns_appresdir=${ns_appdir}/{lispdirrel} ns_appsrc=Cocoa/Emacs.base ns_fontfile=macfont.o elif flags=$( (gnustep-config --objc-flags) 2>/dev/null); then @@ -5325,6 +5327,7 @@ AC_SUBST(sharedstatedir) AC_SUBST(libexecdir) AC_SUBST(mandir) AC_SUBST(infodir) +AC_SUBST(lispdirrel) AC_SUBST(lispdir) AC_SUBST(standardlisppath) AC_SUBST(locallisppath) diff --git a/src/comp.c b/src/comp.c index 058ce7e96a..5663c9e562 100644 --- a/src/comp.c +++ b/src/comp.c @@ -4050,27 +4050,15 @@ If BASE-DIR is nil use the first entry in `comp-eln-load-path'. */) As installing .eln files compiled during the build changes their absolute path we need an hashing mechanism that is not sensitive to that. For this we replace if match PATH_DUMPLOADSEARCH or - PATH_LOADSEARCH with '//' before generating the hash. */ + *PATH_REL_LOADSEARCH with '//' before computing the hash. */ if (NILP (loadsearch_re_list)) { - Lisp_Object sys_re; -#ifdef __APPLE__ - /* On MacOS we relax the match on PATH_LOADSEARCH making - everything before ".app/" a wildcard. This to obtain a - self-contained Emacs.app (bug#43532). */ - char *c; - if ((c = strstr (PATH_LOADSEARCH, ".app/"))) - sys_re = - concat2 (build_string ("\\`[[:ascii:]]+"), - Fregexp_quote (build_string (c))); - else - sys_re = Fregexp_quote (build_string (PATH_LOADSEARCH)); -#else - sys_re = Fregexp_quote (build_string (PATH_LOADSEARCH)); -#endif + Lisp_Object sys_re = + concat2 (build_string ("\\`[[:ascii:]]+"), + Fregexp_quote (build_string ("/" PATH_REL_LOADSEARCH "/"))); loadsearch_re_list = - list2 (sys_re, Fregexp_quote (build_string (PATH_DUMPLOADSEARCH))); + list2 (sys_re, Fregexp_quote (build_string (PATH_DUMPLOADSEARCH "/"))); } Lisp_Object lds_re_tail = loadsearch_re_list; diff --git a/src/epaths.in b/src/epaths.in index 3cadd160ec..5b6c650b0d 100644 --- a/src/epaths.in +++ b/src/epaths.in @@ -27,6 +27,10 @@ along with GNU Emacs. If not, see . */ */ #define PATH_LOADSEARCH "/usr/local/share/emacs/lisp" +/* Like PATH_LOADSEARCH, but contains the relative path from the + installation directory. +*/ +#define PATH_REL_LOADSEARCH "" /* Like PATH_LOADSEARCH, but contains the non-standard pieces. These are the site-lisp directories. Configure sets this to commit 187a0333bf0d1c5dd08ec76c9265e5a6077f8e74 Author: Andrea Corallo Date: Sun Oct 4 09:12:49 2020 +0200 * configure.ac: Better HAVE_NATIVE_COMP description diff --git a/configure.ac b/configure.ac index 990933afc9..3d24751c93 100644 --- a/configure.ac +++ b/configure.ac @@ -3809,7 +3809,7 @@ if test "${with_nativecomp}" != "no"; then LIBGCCJIT_LIB="-lgccjit -ldl" fi NEED_DYNLIB=yes - AC_DEFINE(HAVE_NATIVE_COMP, 1, [Define to 1 if you have the libgccjit library (-lgccjit).]) + AC_DEFINE(HAVE_NATIVE_COMP, 1, [Define to 1 if native compiler is available.]) fi AC_DEFINE_UNQUOTED(NATIVE_ELISP_SUFFIX, ".eln", [System extension for native compiled elisp]) commit 72682958683174b5133b09fd9ac256727e4d88a7 Author: Andrea Corallo Date: Sat Oct 3 21:54:27 2020 +0200 * Fix function description message for native compiled lisp functions * lisp/help-fns.el (help-fns-function-description-header): Fix message. diff --git a/lisp/help-fns.el b/lisp/help-fns.el index 9fee156f18..8287fab315 100644 --- a/lisp/help-fns.el +++ b/lisp/help-fns.el @@ -737,7 +737,7 @@ Returns a list of the form (REAL-FUNCTION DEF ALIASED REAL-DEF)." (aliased (format-message "an alias for `%s'" real-def)) ((subr-native-elisp-p def) - "native compiled Lisp function") + (concat beg "native compiled Lisp function")) ((subrp def) (concat beg (if (eq 'unevalled (cdr (subr-arity def))) "special form" commit 0373bb838a032f97ae9317546e3b0117b97055a8 Author: Andrea Corallo Date: Sat Oct 3 20:57:57 2020 +0200 * Fix two tests in help-fns-tests.el for native code * test/lisp/help-fns-tests.el (help-fns-test-lisp-defun) (help-fns-test-lisp-defsubst): Fix description string for native compiled functions. diff --git a/test/lisp/help-fns-tests.el b/test/lisp/help-fns-tests.el index 811b367791..2f6abfb56d 100644 --- a/test/lisp/help-fns-tests.el +++ b/test/lisp/help-fns-tests.el @@ -61,12 +61,16 @@ Return first line of the output of (describe-function-1 FUNC)." (should (string-match regexp result)))) (ert-deftest help-fns-test-lisp-defun () - (let ((regexp "a compiled Lisp function in .subr\\.el") + (let ((regexp (if (boundp 'comp-ctxt) + "a native compiled Lisp function in .subr\\.el" + "a compiled Lisp function in .subr\\.el")) (result (help-fns-tests--describe-function 'last))) (should (string-match regexp result)))) (ert-deftest help-fns-test-lisp-defsubst () - (let ((regexp "a compiled Lisp function in .subr\\.el") + (let ((regexp (if (boundp 'comp-ctxt) + "a native compiled Lisp function in .subr\\.el" + "a compiled Lisp function in .subr\\.el")) (result (help-fns-tests--describe-function 'posn-window))) (should (string-match regexp result)))) commit 825e85b393a3d78ba43176ecc5bc1a9595d0fbea Author: Andrea Corallo Date: Fri Oct 2 18:38:02 2020 +0200 Use `advice-flet' in place of `cl-letf' to avoid primitive redefinition * test/lisp/time-stamp-tests.el (with-time-stamp-system-name): Use `advice-flet' to advice primitive avoiding redefinition. * test/lisp/tempo-tests.el (tempo-p-element-test) (tempo-P-element-test, tempo-r-element-test) (tempo-s-element-test, tempo-r>-element-test): Likewise. * test/lisp/subr-tests.el (subr-tests-bug22027): Likewise. * test/lisp/shadowfile-tests.el (shadow-test00-clusters) (shadow-test01-sites, shadow-test06-literal-groups) (shadow-test07-regexp-groups): Likewise. * test/lisp/replace-tests.el (replace-tests-with-undo): Likewise. * test/lisp/play/dissociate-tests.el (dissociate-tests-dissociated-press): Likewise. * test/lisp/net/tramp-tests.el (tramp-test10-write-region) (tramp-test21-file-links): Likewise. * test/lisp/kmacro-tests.el (kmacro-tests-call-macro-hint-and-repeat) (kmacro-tests-repeat-on-last-key) (kmacro-tests-repeat-view-and-run) (kmacro-tests-bind-to-key-with-key-sequence-in-use): Likewise. * test/lisp/files-tests.el (files-tests-read-file-in-~): Likewise. * test/lisp/emacs-lisp/rmc-tests.el (test-read-multiple-choice): Likewise. * test/lisp/bookmark-tests.el (bookmark-test-bmenu-locate): Likewise. * test/lisp/abbrev-tests.el (inverse-add-abbrev-skips-trailing-nonword) (inverse-add-abbrev-skips-trailing-nonword/positive-arg) (inverse-add-abbrev-skips-trailing-nonword/negative-arg): Likewise. diff --git a/test/lisp/abbrev-tests.el b/test/lisp/abbrev-tests.el index aaf1d4a5b5..9b998add23 100644 --- a/test/lisp/abbrev-tests.el +++ b/test/lisp/abbrev-tests.el @@ -279,7 +279,7 @@ (let ((table (make-abbrev-table))) (with-temp-buffer (insert "some text foo ") - (cl-letf (((symbol-function 'read-string) (lambda (&rest _) "bar"))) + (advice-flet ((read-string (lambda (&rest _) "bar"))) (inverse-add-abbrev table "Global" 1))) (should (string= (abbrev-expansion "foo" table) "bar")))) @@ -288,7 +288,7 @@ (let ((table (make-abbrev-table))) (with-temp-buffer (insert "some text foo ") - (cl-letf (((symbol-function 'read-string) (lambda (&rest _) "bar"))) + (advice-flet ((read-string (lambda (&rest _) "bar"))) (inverse-add-abbrev table "Global" 2))) (should (string= (abbrev-expansion "text" table) "bar")))) @@ -298,7 +298,7 @@ (with-temp-buffer (insert "some text foo") (goto-char (point-min)) - (cl-letf (((symbol-function 'read-string) (lambda (&rest _) "bar"))) + (advice-flet ((read-string (lambda (&rest _) "bar"))) (inverse-add-abbrev table "Global" -1))) (should (string= (abbrev-expansion "text" table) "bar")))) diff --git a/test/lisp/bookmark-tests.el b/test/lisp/bookmark-tests.el index c5959e46d8..26d75ce0c4 100644 --- a/test/lisp/bookmark-tests.el +++ b/test/lisp/bookmark-tests.el @@ -633,9 +633,9 @@ testing `bookmark-bmenu-list'." (ert-deftest bookmark-test-bmenu-locate () (let (msg) - (cl-letf (((symbol-function 'message) - (lambda (&rest args) - (setq msg (apply #'format args))))) + (advice-flet ((message + (lambda (&rest args) + (setq msg (apply #'format args))))) (with-bookmark-bmenu-test (bookmark-bmenu-locate) (should (equal msg "/some/file")))))) diff --git a/test/lisp/emacs-lisp/rmc-tests.el b/test/lisp/emacs-lisp/rmc-tests.el index 5add24c479..de6db13347 100644 --- a/test/lisp/emacs-lisp/rmc-tests.el +++ b/test/lisp/emacs-lisp/rmc-tests.el @@ -33,10 +33,12 @@ (ert-deftest test-read-multiple-choice () (dolist (char '(?y ?n)) - (cl-letf* (((symbol-function #'read-event) (lambda () char)) - (str (if (eq char ?y) "yes" "no"))) - (should (equal (list char str) - (read-multiple-choice "Do it? " '((?y "yes") (?n "no")))))))) + (let ((str (if (eq char ?y) "yes" "no"))) + (advice-flet ((read-event + (lambda () char))) + (should (equal (list char str) + (read-multiple-choice "Do it? " + '((?y "yes") (?n "no"))))))))) (provide 'rmc-tests) diff --git a/test/lisp/files-tests.el b/test/lisp/files-tests.el index 54801adda6..2e9c6adc94 100644 --- a/test/lisp/files-tests.el +++ b/test/lisp/files-tests.el @@ -242,24 +242,25 @@ form.") "Test file prompting in directory named `~'. If we are in a directory named `~', the default value should not be $HOME." - (cl-letf (((symbol-function 'completing-read) - (lambda (_prompt _coll &optional _pred _req init _hist def _) - (or def init))) - (dir (make-temp-file "read-file-name-test" t))) - (unwind-protect - (let ((subdir (expand-file-name "./~/" dir))) - (make-directory subdir t) - (with-temp-buffer - (setq default-directory subdir) - (should-not (equal - (expand-file-name (read-file-name "File: ")) - (expand-file-name "~/"))) - ;; Don't overquote either! - (setq default-directory (concat "/:" subdir)) - (should-not (equal - (expand-file-name (read-file-name "File: ")) - (concat "/:/:" subdir))))) - (delete-directory dir 'recursive)))) + (let* ((dir (make-temp-file "read-file-name-test" t)) + (subdir (expand-file-name "./~/" dir))) + (advice-flet ((completing-read + (lambda (_prompt _coll &optional _pred _req init _hist def _) + (or def init)))) + (unwind-protect + (progn + (make-directory subdir t) + (with-temp-buffer + (setq default-directory subdir) + (should-not (equal + (expand-file-name (read-file-name "File: ")) + (expand-file-name "~/"))) + ;; Don't overquote either! + (setq default-directory (concat "/:" subdir)) + (should-not (equal + (expand-file-name (read-file-name "File: ")) + (concat "/:/:" subdir))))) + (delete-directory dir 'recursive))))) (ert-deftest files-tests-file-name-non-special-quote-unquote () (let (;; Just in case it is quoted, who knows. diff --git a/test/lisp/kmacro-tests.el b/test/lisp/kmacro-tests.el index bb18c82814..cc0f48eee8 100644 --- a/test/lisp/kmacro-tests.el +++ b/test/lisp/kmacro-tests.el @@ -341,8 +341,8 @@ This is a regression test for: Bug#3412, Bug#11817." (message "") ; Clear the echo area. (Bug#3412) (kmacro-tests-should-match-message "Type e to repeat macro" (kmacro-tests-should-insert "mmmmmm" - (cl-letf (((symbol-function #'this-single-command-keys) (lambda () - [?\C-x ?e]))) + (advice-flet ((this-single-command-keys (lambda () + [?\C-x ?e]))) (kmacro-call-macro 3)) ;; Check that it set up for repeat, and run the repeat. (funcall (lookup-key overriding-terminal-local-map "e")))))) @@ -455,8 +455,8 @@ This is a regression test for: Bug#3412, Bug#11817." ;; commands so it should end the sequence. (let* ((end-key (kmacro-tests-get-kmacro-key 'kmacro-set-counter)) (kmacro-tests-events (append events (list end-key)))) - (cl-letf (((symbol-function #'this-single-command-keys) - (lambda () first-event))) + (advice-flet ((this-single-command-keys + (lambda () first-event))) (use-local-map kmacro-tests-keymap) (kmacro-tests-should-insert "ccbacb" ;; End #3 and launch loop to read events. @@ -466,9 +466,9 @@ This is a regression test for: Bug#3412, Bug#11817." ;; so run it again with that at the end. (let* ((end-key (kmacro-tests-get-kmacro-key 'kmacro-edit-macro-repeat)) (kmacro-tests-events (append events (list end-key)))) - (cl-letf (((symbol-function #'edit-kbd-macro) #'ignore) - ((symbol-function #'this-single-command-keys) - (lambda () first-event))) + (advice-flet ((edit-kbd-macro #'ignore) + (this-single-command-keys + (lambda () first-event))) (use-local-map kmacro-tests-keymap) (kmacro-tests-should-insert "bbbbbaaba" (kmacro-end-or-call-macro-repeat 3))))))) @@ -494,20 +494,22 @@ This is a regression test for: Bug#3412, Bug#11817." '("d" "c" "b" "a" "d" "c"))))) (cl-letf ((kmacro-repeat-no-prefix t) (kmacro-call-repeat-key t) - (kmacro-call-repeat-with-arg nil) - ((symbol-function #'this-single-command-keys) (lambda () - first-event))) - ;; "Record" some macros. - (dotimes (n 4) - (kmacro-tests-define-macro (make-vector 1 (+ ?a n)))) - - (use-local-map kmacro-tests-keymap) - ;; 6 views (the direct call plus the 5 in events) should - ;; cycle through the ring and get to the second-to-last - ;; macro defined. - (kmacro-tests-should-insert "c" - (kmacro-tests-should-match-message macros-regexp - (kmacro-tests-simulate-command '(kmacro-view-macro-repeat nil))))))) + (kmacro-call-repeat-with-arg nil)) + (advice-flet ((this-single-command-keys (lambda () + first-event))) + ;; "Record" some macros. + (dotimes (n 4) + (kmacro-tests-define-macro (make-vector 1 (+ ?a n)))) + + (use-local-map kmacro-tests-keymap) + ;; 6 views (the direct call plus the 5 in events) should + ;; cycle through the ring and get to the second-to-last + ;; macro defined. + (kmacro-tests-should-insert + "c" + (kmacro-tests-should-match-message + macros-regexp + (kmacro-tests-simulate-command '(kmacro-view-macro-repeat nil)))))))) (kmacro-tests-deftest kmacro-tests-bind-to-key-when-recording () "Bind to key doesn't bind a key during macro recording." @@ -542,18 +544,18 @@ This is a regression test for: Bug#3412, Bug#11817." (define-key map "\C-hi" 'info) (use-local-map map) ;; Try the command with yes-or-no-p set up to say no. - (cl-letf (((symbol-function #'yes-or-no-p) - (lambda (prompt) - (should (string-match-p "info" prompt)) - (should (string-match-p "C-h i" prompt)) - nil))) + (advice-flet ((yes-or-no-p + (lambda (prompt) + (should (string-match-p "info" prompt)) + (should (string-match-p "C-h i" prompt)) + nil))) (kmacro-bind-to-key nil)) (should (equal (where-is-internal 'info nil t) (vconcat "\C-hi"))) ;; Try it again with yes. - (cl-letf (((symbol-function #' yes-or-no-p) - (lambda (_prompt) t))) + (advice-flet ((yes-or-no-p + (lambda (_prompt) t))) (kmacro-bind-to-key nil)) (should-not (equal (where-is-internal 'info global-map t) diff --git a/test/lisp/net/tramp-tests.el b/test/lisp/net/tramp-tests.el index 3914f9ae44..0e4fcb5951 100644 --- a/test/lisp/net/tramp-tests.el +++ b/test/lisp/net/tramp-tests.el @@ -2420,16 +2420,16 @@ This checks also `file-name-as-directory', `file-name-directory', tramp--test-messages)))))))) ;; Do not overwrite if excluded. - (cl-letf (((symbol-function #'y-or-n-p) (lambda (_prompt) t)) - ;; Ange-FTP. - ((symbol-function 'yes-or-no-p) (lambda (_prompt) t))) + (advice-flet ((y-or-n-p (lambda (_prompt) t)) + ;; Ange-FTP. + (yes-or-no-p (lambda (_prompt) t))) (write-region "foo" nil tmp-name nil nil nil 'mustbenew)) ;; `mustbenew' is passed to Tramp since Emacs 26.1. (when (tramp--test-emacs26-p) (should-error - (cl-letf (((symbol-function #'y-or-n-p) #'ignore) - ;; Ange-FTP. - ((symbol-function 'yes-or-no-p) 'ignore)) + (advice-flet ((y-or-n-p #'ignore) + ;; Ange-FTP. + (yes-or-no-p 'ignore)) (write-region "foo" nil tmp-name nil nil nil 'mustbenew)) :type 'file-already-exists) (should-error @@ -3522,11 +3522,11 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." :type 'file-already-exists)) (when (tramp--test-expensive-test) ;; A number means interactive case. - (cl-letf (((symbol-function #'yes-or-no-p) #'ignore)) + (advice-flet ((yes-or-no-p #'ignore)) (should-error (make-symbolic-link tmp-name1 tmp-name2 0) :type 'file-already-exists))) - (cl-letf (((symbol-function #'yes-or-no-p) (lambda (_prompt) t))) + (advice-flet ((yes-or-no-p (lambda (_prompt) t))) (make-symbolic-link tmp-name1 tmp-name2 0) (should (string-equal @@ -3598,11 +3598,11 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (add-name-to-file tmp-name1 tmp-name2) :type 'file-already-exists) ;; A number means interactive case. - (cl-letf (((symbol-function #'yes-or-no-p) #'ignore)) + (advice-flet ((yes-or-no-p #'ignore)) (should-error (add-name-to-file tmp-name1 tmp-name2 0) :type 'file-already-exists)) - (cl-letf (((symbol-function #'yes-or-no-p) (lambda (_prompt) t))) + (advice-flet ((yes-or-no-p (lambda (_prompt) t))) (add-name-to-file tmp-name1 tmp-name2 0) (should (file-regular-p tmp-name2))) (add-name-to-file tmp-name1 tmp-name2 'ok-if-already-exists) diff --git a/test/lisp/play/dissociate-tests.el b/test/lisp/play/dissociate-tests.el index e8d903109f..1583a51acd 100644 --- a/test/lisp/play/dissociate-tests.el +++ b/test/lisp/play/dissociate-tests.el @@ -25,8 +25,8 @@ (require 'dissociate) (ert-deftest dissociate-tests-dissociated-press () - (cl-letf (((symbol-function 'y-or-n-p) (lambda (_) nil)) - ((symbol-function 'random) (lambda (_) 10))) + (advice-flet ((y-or-n-p (lambda (_) nil)) + (random (lambda (_) 10))) (save-window-excursion (with-temp-buffer (insert "Lorem ipsum dolor sit amet") diff --git a/test/lisp/replace-tests.el b/test/lisp/replace-tests.el index aed14c3357..0f8084704d 100644 --- a/test/lisp/replace-tests.el +++ b/test/lisp/replace-tests.el @@ -443,29 +443,28 @@ Return the last evalled form in BODY." ;; Bind `read-event' to simulate user input. ;; If `replace-tests-bind-read-string' is non-nil, then ;; bind `read-string' as well. - (cl-letf (((symbol-function 'read-event) - (lambda (&rest _args) - (cl-incf ,count) - (pcase ,count ; Build the clauses from CHAR-NUMS - ,@(append - (delq nil - (mapcar - (lambda (chr) - (when-let (it (alist-get chr char-nums)) - (if (cdr it) - `(,(cons 'or it) ,chr) - `(,(car it) ,chr)))) - '(?, ?\s ?u ?U ?E ?q))) - `((_ ,def-chr)))))) - ((symbol-function 'read-string) - (if replace-tests-bind-read-string - (lambda (&rest _args) replace-tests-bind-read-string) - (symbol-function 'read-string))) - ;; Emulate replace-highlight clobbering match-data via - ;; isearch-lazy-highlight-new-loop and sit-for (bug#36328) - ((symbol-function 'replace-highlight) - (lambda (&rest _args) - (string-match "[A-Z ]" "ForestGreen")))) + (advice-flet ((read-event + (lambda (&rest _args) + (cl-incf ,count) + (pcase ,count ; Build the clauses from CHAR-NUMS + ,@(append + (delq nil + (mapcar + (lambda (chr) + (when-let (it (alist-get chr char-nums)) + (if (cdr it) + `(,(cons 'or it) ,chr) + `(,(car it) ,chr)))) + '(?, ?\s ?u ?U ?E ?q))) + `((_ ,def-chr)))))) + (read-string + (if replace-tests-bind-read-string + (lambda (&rest _args) replace-tests-bind-read-string) + (lambda (&rest args) + (apply #'read-string args)))) + (replace-highlight + (lambda (&rest _args) + (string-match "[A-Z ]" "ForestGreen")))) (perform-replace ,from ,to t replace-tests-perform-replace-regexp-flag nil)) ,@body)))) diff --git a/test/lisp/shadowfile-tests.el b/test/lisp/shadowfile-tests.el index f40f6a1cdb..6a9664638f 100644 --- a/test/lisp/shadowfile-tests.el +++ b/test/lisp/shadowfile-tests.el @@ -138,10 +138,10 @@ guaranteed by the originator of a cluster definition." (unwind-protect ;; We must mock `read-from-minibuffer' and `read-string', in ;; order to avoid interactive arguments. - (cl-letf* (((symbol-function #'read-from-minibuffer) - (lambda (&rest _args) (pop mocked-input))) - ((symbol-function #'read-string) - (lambda (&rest _args) (pop mocked-input)))) + (advice-flet ((read-from-minibuffer + (lambda (&rest _args) (pop mocked-input))) + (read-string + (lambda (&rest _args) (pop mocked-input)))) ;; Cleanup & initialize. (shadow--tests-cleanup) @@ -255,10 +255,10 @@ guaranteed by the originator of a cluster definition." (unwind-protect ;; We must mock `read-from-minibuffer' and `read-string', in ;; order to avoid interactive arguments. - (cl-letf* (((symbol-function #'read-from-minibuffer) - (lambda (&rest _args) (pop mocked-input))) - ((symbol-function #'read-string) - (lambda (&rest _args) (pop mocked-input)))) + (advice-flet ((read-from-minibuffer + (lambda (&rest _args) (pop mocked-input))) + (read-string + (lambda (&rest _args) (pop mocked-input)))) ;; Cleanup & initialize. (shadow--tests-cleanup) @@ -608,10 +608,10 @@ guaranteed by the originator of a cluster definition." (unwind-protect ;; We must mock `read-from-minibuffer' and `read-string', in ;; order to avoid interactive arguments. - (cl-letf* (((symbol-function #'read-from-minibuffer) - (lambda (&rest _args) (pop mocked-input))) - ((symbol-function #'read-string) - (lambda (&rest _args) (pop mocked-input)))) + (advice-flet ((read-from-minibuffer + (lambda (&rest _args) (pop mocked-input))) + (read-string + (lambda (&rest _args) (pop mocked-input)))) ;; Cleanup & initialize. (shadow--tests-cleanup) @@ -669,10 +669,10 @@ guaranteed by the originator of a cluster definition." (unwind-protect ;; We must mock `read-from-minibuffer' and `read-string', in ;; order to avoid interactive arguments. - (cl-letf* (((symbol-function #'read-from-minibuffer) - (lambda (&rest _args) (pop mocked-input))) - ((symbol-function #'read-string) - (lambda (&rest _args) (pop mocked-input)))) + (advice-flet ((read-from-minibuffer + (lambda (&rest _args) (pop mocked-input))) + (read-string + (lambda (&rest _args) (pop mocked-input)))) ;; Cleanup & initialize. (shadow--tests-cleanup) diff --git a/test/lisp/subr-tests.el b/test/lisp/subr-tests.el index 035c064d75..b131b50935 100644 --- a/test/lisp/subr-tests.el +++ b/test/lisp/subr-tests.el @@ -337,8 +337,8 @@ cf. Bug#25477." (ert-deftest subr-tests-bug22027 () "Test for https://debbugs.gnu.org/22027 ." (let ((default "foo") res) - (cl-letf (((symbol-function 'read-string) - (lambda (_prompt _init _hist def) def))) + (advice-flet ((read-string + (lambda (_prompt _init _hist def) def))) (setq res (read-passwd "pass: " 'confirm (mapconcat #'string default ""))) (should (string= default res))))) diff --git a/test/lisp/tempo-tests.el b/test/lisp/tempo-tests.el index bfe475910d..333abffc84 100644 --- a/test/lisp/tempo-tests.el +++ b/test/lisp/tempo-tests.el @@ -55,7 +55,7 @@ (with-temp-buffer (tempo-define-template "test" '("hello " (p ">"))) (let ((tempo-interactive t)) - (cl-letf (((symbol-function 'read-string) (lambda (&rest _) "world"))) + (advice-flet ((read-string (lambda (&rest _) "world"))) (tempo-insert-template 'tempo-template-test nil)) (should (equal (buffer-string) "hello world"))))) @@ -64,7 +64,7 @@ (with-temp-buffer (tempo-define-template "test" '("hello " (P ">"))) ;; By default, `tempo-interactive' is nil, `P' should ignore this. - (cl-letf (((symbol-function 'read-string) (lambda (&rest _) "world"))) + (advice-flet ((read-string (lambda (&rest _) "world"))) (tempo-insert-template 'tempo-template-test nil)) (should (equal (buffer-string) "hello world")))) @@ -73,7 +73,7 @@ (with-temp-buffer (tempo-define-template "test" '("abcde" (r ">") "ghijk")) (let ((tempo-interactive t)) - (cl-letf (((symbol-function 'read-string) (lambda (&rest _) "F"))) + (advice-flet ((read-string (lambda (&rest _) "F"))) (tempo-insert-template 'tempo-template-test nil)) (should (equal (buffer-string) "abcdeFghijk"))))) @@ -82,7 +82,7 @@ (with-temp-buffer (tempo-define-template "test" '("hello " (p ">" P1) " " (s P1))) (let ((tempo-interactive t)) - (cl-letf (((symbol-function 'read-string) (lambda (&rest _) "world!"))) + (advice-flet ((read-string (lambda (&rest _) "world!"))) (tempo-insert-template 'tempo-template-test nil)) (should (equal (buffer-string) "hello world! world!"))))) @@ -164,7 +164,7 @@ ;; Test interactive use (emacs-lisp-mode) (let ((tempo-interactive t)) - (cl-letf (((symbol-function 'read-string) (lambda (&rest _) " (list 1 2 3)"))) + (advice-flet ((read-string (lambda (&rest _) " (list 1 2 3)"))) (tempo-insert-template 'tempo-template-test nil)) (should (equal (buffer-string) "(progn\n (list 1 2 3))"))))) diff --git a/test/lisp/time-stamp-tests.el b/test/lisp/time-stamp-tests.el index e75e84b022..ab662ffd95 100644 --- a/test/lisp/time-stamp-tests.el +++ b/test/lisp/time-stamp-tests.el @@ -57,8 +57,8 @@ (defmacro with-time-stamp-system-name (name &rest body) "Force (system-name) to return NAME while evaluating BODY." (declare (indent defun)) - `(cl-letf (((symbol-function 'system-name) - (lambda () ,name))) + `(advice-flet ((system-name + (lambda () ,name))) ,@body)) (defmacro time-stamp-should-warn (form) commit d07d7ab1a0e321ced62ebe5dd9db27eb7e93430e Author: Andrea Corallo Date: Fri Oct 2 18:13:28 2020 +0200 Add `advice-flet' macro The testsuite does large use of primitive redefinition, to avoid that we define `advice-flet' to use instead as an easy `cl-letf' replacement. * lisp/emacs-lisp/nadvice.el (advice-flet): New macro. diff --git a/lisp/emacs-lisp/nadvice.el b/lisp/emacs-lisp/nadvice.el index 5b3aa70850..21da038dc1 100644 --- a/lisp/emacs-lisp/nadvice.el +++ b/lisp/emacs-lisp/nadvice.el @@ -356,6 +356,32 @@ of the piece of advice." (macroexp-let2 nil new `(advice--remove-function ,getter ,function) `(unless (eq ,new ,getter) ,(funcall setter new))))) +;;;###autoload +(defmacro advice-flet (bindings &rest body) + ;; FIXME add doc. + (declare (indent 1)) + (let ((let-binds ()) + (ad-add ()) + (ad-del ())) + (dolist (bind bindings) + (let* ((fun-name (car bind)) + (fun (cadr bind)) + (tmp-sym (gensym (symbol-name fun-name)))) + (push `(,tmp-sym ,fun) let-binds) + (push `(advice-add #',fun-name + ,(if (= (length bind) 3) + (nth 2 bind) + :override) + ,tmp-sym) + ad-add) + (push `(advice-remove #',fun-name ,tmp-sym) ad-del))) + `(let ,(reverse let-binds) + (unwind-protect + (progn + ,@(reverse ad-add) + ,@body) + ,@(reverse ad-del))))) + (defun advice-function-mapc (f function-def) "Apply F to every advice function in FUNCTION-DEF. F is called with two arguments: the function that was added, and the commit 36e0c3fb07db9805e97fbd2650aa28ac2c169dba Author: Andrea Corallo Date: Fri Oct 2 14:42:43 2020 +0200 * When advising search in `comp-eln-load-path' the first writable dir * lisp/emacs-lisp/comp.el (comp-tampoline-compile): Do not crash if we can't write in the first entry in `comp-eln-load-path' but search for another one. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 02b08119f9..ef13c0ce63 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2593,17 +2593,25 @@ Return the its filename if found or nil otherwise." ;; the primitive we are replacing in the function reloc table. (defalias trampoline-sym `(closure nil ,lambda-list - (let ((f #',subr-name)) - (,(if (memq '&rest lambda-list) 'apply 'funcall) - f - ,@(cl-loop - for arg in lambda-list - unless (memq arg '(&optional &rest)) - collect arg))))) - (native-compile trampoline-sym nil - (expand-file-name (comp-trampoline-filename subr-name) - (concat (car comp-eln-load-path) - comp-native-version-dir))))) + (let ((f #',subr-name)) + (,(if (memq '&rest lambda-list) 'apply 'funcall) + f + ,@(cl-loop + for arg in lambda-list + unless (memq arg '(&optional &rest)) + collect arg))))) + (native-compile + trampoline-sym nil + (cl-loop + for dir in comp-eln-load-path + for f = (expand-file-name + (comp-trampoline-filename subr-name) + (concat dir + comp-native-version-dir)) + when (file-writable-p f) + do (cl-return f) + finally (error "Can't find a writable directory in \ +`comp-eln-load-path'"))))) ;;;###autoload (defun comp-subr-safe-advice (subr-name) commit 8dacc9e8c52ce873f2b0a54e7ca67cffd2c7f4f7 Author: Andrea Corallo Date: Fri Oct 2 13:49:20 2020 +0200 * Fix 'incoherent dumped eln file' error when DUMP-METHOD=pbootstrap * src/Makefile.in ($(bootstrap_pdmp)): Add missing --bin-dest --eln-dest flags. diff --git a/src/Makefile.in b/src/Makefile.in index 31a5a7e770..001f0c4072 100644 --- a/src/Makefile.in +++ b/src/Makefile.in @@ -820,7 +820,8 @@ endif ifeq ($(DUMPING),pdumper) $(bootstrap_pdmp): bootstrap-emacs$(EXEEXT) rm -f $@ - $(RUN_TEMACS) --batch $(BUILD_DETAILS) -l loadup --temacs=pbootstrap + $(RUN_TEMACS) --batch $(BUILD_DETAILS) -l loadup --temacs=pbootstrap \ + --bin-dest $(BIN_DESTDIR) --eln-dest $(ELN_DESTDIR) @: Compile some files earlier to speed up further compilation. $(MAKE) -C ../lisp compile-first EMACS="$(bootstrap_exe)" endif commit 6a0994bc976534e56aa4990584f363536bc35271 Author: Andrea Corallo Date: Fri Oct 2 13:47:29 2020 +0200 * src/pdumper.c (dump_do_dump_relocation): Better error for incoherent eln. diff --git a/src/pdumper.c b/src/pdumper.c index 03391c4950..0528219139 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -5250,7 +5250,8 @@ dump_do_dump_relocation (const uintptr_t dump_base, dump_ptr (dump_base, reloc_offset); comp_u->lambda_gc_guard_h = CALLN (Fmake_hash_table, QCtest, Qeq); if (!CONSP (comp_u->file)) - error ("Trying to load incoherent dumped .eln"); + error ("Trying to load incoherent dumped eln file %s", + SSDATA (comp_u->file)); /* Check just once if this is a local build or Emacs was installed. */ if (installation_state == UNKNOWN) commit f345622152786388f4689f81f91acabe6eab9500 Author: Andrea Corallo Date: Fri Oct 2 09:52:40 2020 +0200 Clean-up testsuite for vanilla builds Tag all native compiler tests and skip them in vanilla builds * test/Makefile.in (SELECTOR_DEFAULT, SELECTOR_EXPENSIVE) (SELECTOR_ALL): Define selectors for vanilla or nativecomp builds. * test/src/comp-tests.el: Do not native compile test files on vanilla. (comp-deftest): New macro to define tests tagging as :nativecomp. diff --git a/test/Makefile.in b/test/Makefile.in index 9974eb54b0..4a5cbee8c8 100644 --- a/test/Makefile.in +++ b/test/Makefile.in @@ -70,6 +70,7 @@ am__v_at_ = $(am__v_at_@AM_DEFAULT_V@) am__v_at_0 = @ am__v_at_1 = +HAVE_NATIVE_COMP = @HAVE_NATIVE_COMP@ # We never change directory before running Emacs, so a relative file # name is fine, and makes life easier. If we need to change @@ -138,9 +139,15 @@ test_module_dir := data/emacs-module all: check +ifeq ($(HAVE_NATIVE_COMP),yes) SELECTOR_DEFAULT = (not (or (tag :expensive-test) (tag :unstable))) SELECTOR_EXPENSIVE = (not (tag :unstable)) SELECTOR_ALL = t +else +SELECTOR_DEFAULT = (not (or (tag :expensive-test) (tag :unstable) (tag :nativecomp))) +SELECTOR_EXPENSIVE = (not (or (tag :unstable) (tag :nativecomp))) +SELECTOR_ALL = (not (tag :nativecomp)) +endif ifdef SELECTOR SELECTOR_ACTUAL=$(SELECTOR) else ifndef MAKECMDGOALS diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index f76afdbf1c..f954ae6a9d 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -37,16 +37,25 @@ (defconst comp-test-dyn-src (concat comp-test-directory "comp-test-funcs-dyn.el")) -(message "Compiling tests...") -(load (native-compile comp-test-src)) -(load (native-compile comp-test-dyn-src)) +(when (boundp 'comp-ctxt) + (message "Compiling tests...") + (load (native-compile comp-test-src)) + (load (native-compile comp-test-dyn-src))) + +(defmacro comp-deftest (name args &rest docstring-and-body) + "Define a test for the native compiler tagging it as :nativecomp." + (declare (indent defun) + (doc-string 3)) + `(ert-deftest ,(intern (concat "compt-tests-" (symbol-name name))) ,args + :tags '(:nativecomp) + ,@docstring-and-body)) (ert-deftest comp-tests-bootstrap () "Compile the compiler and load it to compile it-self. Check that the resulting binaries do not differ." - :tags '(:expensive-test) + :tags '(:expensive-test :nativecomp) (let* ((comp-src (concat comp-test-directory "../../lisp/emacs-lisp/comp.el")) (comp1-src (make-temp-file "stage1-" nil ".el")) @@ -71,15 +80,15 @@ Check that the resulting binaries do not differ." (message "Comparing %s %s" comp1-eln comp2-eln) (should (= (call-process "cmp" nil nil nil comp1-eln comp2-eln) 0)))))) -(ert-deftest comp-tests-provide () +(comp-deftest provide () "Testing top level provide." (should (featurep 'comp-test-funcs))) -(ert-deftest comp-tests-varref () +(comp-deftest varref () "Testing varref." (should (= (comp-tests-varref-f) 3))) -(ert-deftest comp-tests-list () +(comp-deftest list () "Testing cons car cdr." (should (equal (comp-tests-list-f) '(1 2 3))) (should (equal (comp-tests-list2-f 1 2 3) '(1 2 3))) @@ -96,12 +105,12 @@ Check that the resulting binaries do not differ." (should (= (comp-tests-cdr-safe-f '(1 . 2)) 2)) (should (null (comp-tests-cdr-safe-f 'a)))) -(ert-deftest comp-tests-cons-car-cdr () +(comp-deftest comp-tests-cons-car-cdr () "Testing cons car cdr." (should (= (comp-tests-cons-car-f) 1)) (should (= (comp-tests-cons-cdr-f 3) 3))) -(ert-deftest comp-tests-varset () +(comp-deftest varset () "Testing varset." (comp-tests-varset0-f) (should (= comp-tests-var1 55)) @@ -109,23 +118,23 @@ Check that the resulting binaries do not differ." (should (= (comp-tests-varset1-f) 4)) (should (= comp-tests-var1 66))) -(ert-deftest comp-tests-length () +(comp-deftest length () "Testing length." (should (= (comp-tests-length-f) 3))) -(ert-deftest comp-tests-aref-aset () +(comp-deftest aref-aset () "Testing aref and aset." (should (= (comp-tests-aref-aset-f) 100))) -(ert-deftest comp-tests-symbol-value () +(comp-deftest symbol-value () "Testing aref and aset." (should (= (comp-tests-symbol-value-f) 3))) -(ert-deftest comp-tests-concat () +(comp-deftest concat () "Testing concatX opcodes." (should (string= (comp-tests-concat-f "bar") "abcdabcabfoobar"))) -(ert-deftest comp-tests-ffuncall () +(comp-deftest ffuncall () "Test calling conventions." ;; (defun comp-tests-ffuncall-caller-f () @@ -171,7 +180,7 @@ Check that the resulting binaries do not differ." (should (= (comp-tests-ffuncall-lambda-f 1) 2))) -(ert-deftest comp-tests-jump-table () +(comp-deftest jump-table () "Testing jump tables" (should (eq (comp-tests-jump-table-1-f 'x) 'a)) (should (eq (comp-tests-jump-table-1-f 'y) 'b)) @@ -181,14 +190,14 @@ Check that the resulting binaries do not differ." (should (eq (comp-tests-jump-table-2-f "aaa") 'a)) (should (eq (comp-tests-jump-table-2-f "bbb") 'b))) -(ert-deftest comp-tests-conditionals () +(comp-deftest conditionals () "Testing conditionals." (should (= (comp-tests-conditionals-1-f t) 1)) (should (= (comp-tests-conditionals-1-f nil) 2)) (should (= (comp-tests-conditionals-2-f t) 1340)) (should (eq (comp-tests-conditionals-2-f nil) nil))) -(ert-deftest comp-tests-fixnum () +(comp-deftest fixnum () "Testing some fixnum inline operation." (should (= (comp-tests-fixnum-1-minus-f 10) 9)) (should (= (comp-tests-fixnum-1-minus-f most-negative-fixnum) @@ -206,13 +215,13 @@ Check that the resulting binaries do not differ." (should-error (comp-tests-fixnum-minus-f 'a) :type 'wrong-type-argument)) -(ert-deftest comp-tests-type-hints () +(comp-deftest type-hints () "Just test compiler hints are transparent in this case." ;; FIXME we should really check they are also effective. (should (= (comp-tests-hint-fixnum-f 3) 4)) (should (= (comp-tests-hint-cons-f (cons 1 2)) 1))) -(ert-deftest comp-tests-arith-comp () +(comp-deftest arith-comp () "Testing arithmetic comparisons." (should (eq (comp-tests-eqlsign-f 4 3) nil)) (should (eq (comp-tests-eqlsign-f 3 3) t)) @@ -230,7 +239,7 @@ Check that the resulting binaries do not differ." (should (eq (comp-tests-geq-f 3 3) t)) (should (eq (comp-tests-geq-f 2 3) nil))) -(ert-deftest comp-tests-setcarcdr () +(comp-deftest setcarcdr () "Testing setcar setcdr." (should (equal (comp-tests-setcar-f '(10 . 10) 3) '(3 . 10))) (should (equal (comp-tests-setcdr-f '(10 . 10) 3) '(10 . 3))) @@ -239,14 +248,14 @@ Check that the resulting binaries do not differ." (should-error (comp-tests-setcdr-f 3 10) :type 'wrong-type-argument)) -(ert-deftest comp-tests-bubble-sort () +(comp-deftest bubble-sort () "Run bubble sort." (let* ((list1 (mapcar #'random (make-list 1000 most-positive-fixnum))) (list2 (copy-sequence list1))) (should (equal (comp-bubble-sort-f list1) (sort list2 #'<))))) -(ert-deftest comp-test-apply () +(comp-deftest apply () "Test some inlined list functions." (should (eq (comp-tests-consp-f '(1)) t)) (should (eq (comp-tests-consp-f 1) nil)) @@ -254,7 +263,7 @@ Check that the resulting binaries do not differ." (should (= (comp-tests-setcar2-f x) 3)) (should (equal x '(3 . 2))))) -(ert-deftest comp-tests-num-inline () +(comp-deftest num-inline () "Test some inlined number functions." (should (eq (comp-tests-integerp-f 1) t)) (should (eq (comp-tests-integerp-f '(1)) nil)) @@ -265,7 +274,7 @@ Check that the resulting binaries do not differ." (should (eq (comp-tests-numberp-f 'a) nil)) (should (eq (comp-tests-numberp-f 3.5) t))) -(ert-deftest comp-tests-stack () +(comp-deftest stack () "Test some stack operation." (should (= (comp-tests-discardn-f 10) 2)) (should (string= (with-temp-buffer @@ -273,7 +282,7 @@ Check that the resulting binaries do not differ." (buffer-string)) "abcd"))) -(ert-deftest comp-tests-non-locals () +(comp-deftest non-locals () "Test non locals." (should (string= (comp-tests-condition-case-0-f) "arith-error Arithmetic error catched")) @@ -285,53 +294,53 @@ Check that the resulting binaries do not differ." (should (= (catch 'foo (comp-tests-throw-f 3))))) -(ert-deftest comp-tests-gc () +(comp-deftest gc () "Try to do some longer computation to let the gc kick in." (dotimes (_ 100000) (comp-tests-cons-cdr-f 3)) (should (= (comp-tests-cons-cdr-f 3) 3))) -(ert-deftest comp-tests-buffer () +(comp-deftest buffer () (should (string= (comp-tests-buff0-f) "foo"))) -(ert-deftest comp-tests-lambda-return () +(comp-deftest lambda-return () (let ((f (comp-tests-lambda-return-f))) (should (subr-native-elisp-p f)) (should (= (funcall f 3) 4)))) -(ert-deftest comp-tests-recursive () +(comp-deftest recursive () (should (= (comp-tests-fib-f 10) 55))) -(ert-deftest comp-tests-macro () +(comp-deftest macro () "Just check we can define macros" (should (macrop (symbol-function 'comp-tests-macro-m)))) -(ert-deftest comp-tests-string-trim () +(comp-deftest string-trim () (should (string= (comp-tests-string-trim-f "dsaf ") "dsaf"))) -(ert-deftest comp-tests-trampoline-removal () +(comp-deftest trampoline-removal () ;; This tests that we can can call primitives with no dedicated bytecode. ;; At speed >= 2 the trampoline will not be used. (should (hash-table-p (comp-tests-trampoline-removal-f)))) -(ert-deftest comp-tests-signal () +(comp-deftest signal () (should (equal (condition-case err (comp-tests-signal-f) (t err)) '(foo . t)))) -(ert-deftest comp-tests-func-call-removal () +(comp-deftest func-call-removal () ;; See `comp-propagate-insn' `comp-function-call-remove'. (should (= (comp-tests-func-call-removal-f) 1))) -(ert-deftest comp-tests-doc () +(comp-deftest doc () (should (string= (documentation #'comp-tests-doc-f) "A nice docstring")) ;; Check a preloaded function, we can't use `comp-tests-doc-f' now ;; as this is loaded manually with no .elc. (should (string-match "\\.*.elc\\'" (symbol-file #'error)))) -(ert-deftest comp-test-interactive-form () +(comp-deftest interactive-form () (should (equal (interactive-form #'comp-test-interactive-form0-f) '(interactive "D"))) (should (equal (interactive-form #'comp-test-interactive-form1-f) @@ -343,7 +352,7 @@ Check that the resulting binaries do not differ." comp-test-interactive-form2-f))) (should-not (commandp #'comp-tests-doc-f))) -(ert-deftest comp-tests-free-fun () +(comp-deftest free-fun () "Check we are able to compile a single function." (eval '(defun comp-tests-free-fun-f () "Some doc." @@ -360,24 +369,24 @@ Check that the resulting binaries do not differ." (should (equal (interactive-form #'comp-tests-free-fun-f) '(interactive)))) -(ert-deftest comp-test-40187 () +(comp-deftest bug-40187 () "Check function name shadowing. https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-03/msg00914.html." (should (eq (comp-test-40187-1-f) 'foo)) (should (eq (comp-test-40187-2-f) 'bar))) -(ert-deftest comp-test-speed--1 () +(comp-deftest speed--1 () "Check that at speed -1 we do not native compile." (should (= (comp-test-speed--1-f) 3)) (should-not (subr-native-elisp-p (symbol-function #'comp-test-speed--1-f)))) -(ert-deftest comp-test-42360 () +(comp-deftest bug-42360 () "." (should (string= (comp-test-42360-f "Nel mezzo del " 18 0 32 "yyy" nil) "Nel mezzo del yyy"))) (defvar comp-test-primitive-advice) -(ert-deftest comp-test-primitive-advice () +(comp-deftest primitive-advice () "Test effectiveness of primitve advicing." (let (comp-test-primitive-advice (f (lambda (&rest args) @@ -394,65 +403,65 @@ https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-03/msg00914.html." ;; Tromey's tests. ;; ;;;;;;;;;;;;;;;;;;;;; -(ert-deftest comp-consp () +(comp-deftest consp () (should-not (comp-test-consp 23)) (should-not (comp-test-consp nil)) (should (comp-test-consp '(1 . 2)))) -(ert-deftest comp-listp () +(comp-deftest listp () (should-not (comp-test-listp 23)) (should (comp-test-listp nil)) (should (comp-test-listp '(1 . 2)))) -(ert-deftest comp-stringp () +(comp-deftest stringp () (should-not (comp-test-stringp 23)) (should-not (comp-test-stringp nil)) (should (comp-test-stringp "hi"))) -(ert-deftest comp-symbolp () +(comp-deftest symbolp () (should-not (comp-test-symbolp 23)) (should-not (comp-test-symbolp "hi")) (should (comp-test-symbolp 'whatever))) -(ert-deftest comp-integerp () +(comp-deftest integerp () (should (comp-test-integerp 23)) (should-not (comp-test-integerp 57.5)) (should-not (comp-test-integerp "hi")) (should-not (comp-test-integerp 'whatever))) -(ert-deftest comp-numberp () +(comp-deftest numberp () (should (comp-test-numberp 23)) (should (comp-test-numberp 57.5)) (should-not (comp-test-numberp "hi")) (should-not (comp-test-numberp 'whatever))) -(ert-deftest comp-add1 () +(comp-deftest add1 () (should (eq (comp-test-add1 23) 24)) (should (eq (comp-test-add1 -17) -16)) (should (eql (comp-test-add1 1.0) 2.0)) (should-error (comp-test-add1 nil) :type 'wrong-type-argument)) -(ert-deftest comp-sub1 () +(comp-deftest sub1 () (should (eq (comp-test-sub1 23) 22)) (should (eq (comp-test-sub1 -17) -18)) (should (eql (comp-test-sub1 1.0) 0.0)) (should-error (comp-test-sub1 nil) :type 'wrong-type-argument)) -(ert-deftest comp-negate () +(comp-deftest negate () (should (eq (comp-test-negate 23) -23)) (should (eq (comp-test-negate -17) 17)) (should (eql (comp-test-negate 1.0) -1.0)) (should-error (comp-test-negate nil) :type 'wrong-type-argument)) -(ert-deftest comp-not () +(comp-deftest not () (should (eq (comp-test-not 23) nil)) (should (eq (comp-test-not nil) t)) (should (eq (comp-test-not t) nil))) -(ert-deftest comp-bobp-and-eobp () +(comp-deftest bobp-and-eobp () (with-temp-buffer (should (comp-test-bobp)) (should (comp-test-eobp)) @@ -468,7 +477,7 @@ https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-03/msg00914.html." (should-not (comp-test-bobp)) (should (comp-test-eobp)))) -(ert-deftest comp-car-cdr () +(comp-deftest car-cdr () (let ((pair '(1 . b))) (should (eq (comp-test-car pair) 1)) (should (eq (comp-test-car nil) nil)) @@ -479,7 +488,7 @@ https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-03/msg00914.html." (should-error (comp-test-cdr 23) :type 'wrong-type-argument))) -(ert-deftest comp-car-cdr-safe () +(comp-deftest car-cdr-safe () (let ((pair '(1 . b))) (should (eq (comp-test-car-safe pair) 1)) (should (eq (comp-test-car-safe nil) nil)) @@ -488,59 +497,59 @@ https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-03/msg00914.html." (should (eq (comp-test-cdr-safe nil) nil)) (should (eq (comp-test-cdr-safe 23) nil)))) -(ert-deftest comp-eq () +(comp-deftest eq () (should (comp-test-eq 'a 'a)) (should (comp-test-eq 5 5)) (should-not (comp-test-eq 'a 'b))) -(ert-deftest comp-if () +(comp-deftest if () (should (eq (comp-test-if 'a 'b) 'a)) (should (eq (comp-test-if 0 23) 0)) (should (eq (comp-test-if nil 'b) 'b))) -(ert-deftest comp-and () +(comp-deftest and () (should (eq (comp-test-and 'a 'b) 'b)) (should (eq (comp-test-and 0 23) 23)) (should (eq (comp-test-and nil 'b) nil))) -(ert-deftest comp-or () +(comp-deftest or () (should (eq (comp-test-or 'a 'b) 'a)) (should (eq (comp-test-or 0 23) 0)) (should (eq (comp-test-or nil 'b) 'b))) -(ert-deftest comp-save-excursion () +(comp-deftest save-excursion () (with-temp-buffer (comp-test-save-excursion) (should (eq (point) (point-min))) (should (eq (comp-test-current-buffer) (current-buffer))))) -(ert-deftest comp-> () +(comp-deftest > () (should (eq (comp-test-> 0 23) nil)) (should (eq (comp-test-> 23 0) t))) -(ert-deftest comp-catch () +(comp-deftest catch () (should (eq (comp-test-catch 0 1 2 3 4) nil)) (should (eq (comp-test-catch 20 21 22 23 24 25 26 27 28) 24))) -(ert-deftest comp-memq () +(comp-deftest memq () (should (equal (comp-test-memq 0 '(5 4 3 2 1 0)) '(0))) (should (eq (comp-test-memq 72 '(5 4 3 2 1 0)) nil))) -(ert-deftest comp-listN () +(comp-deftest listN () (should (equal (comp-test-listN 57) '(57 57 57 57 57 57 57 57 57 57 57 57 57 57 57 57)))) -(ert-deftest comp-concatN () +(comp-deftest concatN () (should (equal (comp-test-concatN "x") "xxxxxx"))) -(ert-deftest comp-opt-rest () +(comp-deftest opt-rest () (should (equal (comp-test-opt-rest 1) '(1 nil nil))) (should (equal (comp-test-opt-rest 1 2) '(1 2 nil))) (should (equal (comp-test-opt-rest 1 2 3) '(1 2 (3)))) (should (equal (comp-test-opt-rest 1 2 56 57 58) '(1 2 (56 57 58))))) -(ert-deftest comp-opt () +(comp-deftest opt () (should (equal (comp-test-opt 23) '(23))) (should (equal (comp-test-opt 23 24) '(23 . 24))) (should-error (comp-test-opt) @@ -548,7 +557,7 @@ https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-03/msg00914.html." (should-error (comp-test-opt nil 24 97) :type 'wrong-number-of-arguments)) -(ert-deftest comp-unwind-protect () +(comp-deftest unwind-protect () (comp-test-unwind-protect 'ignore) (should (eq comp-test-up-val 999)) (condition-case nil @@ -562,7 +571,7 @@ https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-03/msg00914.html." ;; Tests for dynamic scope. ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(ert-deftest comp-tests-dynamic-ffuncall () +(comp-deftest dynamic-ffuncall () "Test calling convention for dynamic binding." (should (equal (comp-tests-ffuncall-callee-dyn-f 1 2) @@ -589,7 +598,7 @@ https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-03/msg00914.html." (should (equal (comp-tests-ffuncall-callee-opt-rest-dyn-f 1 2 3 4) '(1 2 3 (4))))) -(ert-deftest comp-tests-dynamic-arity () +(comp-deftest dynamic-arity () "Test func-arity on dynamic scope functions." (should (equal '(2 . 2) (func-arity #'comp-tests-ffuncall-callee-dyn-f))) @@ -600,18 +609,18 @@ https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-03/msg00914.html." (should (equal '(2 . many) (func-arity #'comp-tests-ffuncall-callee-opt-rest-dyn-f)))) -(ert-deftest comp-tests-dynamic-help-arglist () +(comp-deftest dynamic-help-arglist () "Test `help-function-arglist' works on lisp/d (bug#42572)." (should (equal (help-function-arglist (symbol-function #'comp-tests-ffuncall-callee-opt-rest-dyn-f) t) '(a b &optional c &rest d)))) -(ert-deftest comp-tests-cl-macro-exp () +(comp-deftest cl-macro-exp () "Verify CL macro expansion (bug#42088)." (should (equal (comp-tests-cl-macro-exp-f) '(a b)))) -(ert-deftest comp-tests-cl-uninterned-arg-parse-f () +(comp-deftest cl-uninterned-arg-parse-f () "Verify the parsing of a lambda list with uninterned symbols (bug#42120)." (should (equal (comp-tests-cl-uninterned-arg-parse-f 1 2) '(1 2)))) @@ -659,7 +668,7 @@ CHECKER should always return nil to have a pass." (comp-tests-mentioned-p (comp-c-func-name 'comp-tests-tco-f "F" t) insn))))) -(ert-deftest comp-tests-tco () +(comp-deftest tco () "Check for tail recursion elimination." (let ((comp-speed 3) ;; Disable ipa-pure otherwise `comp-tests-tco-f' gets @@ -684,7 +693,7 @@ CHECKER should always return nil to have a pass." (or (comp-tests-mentioned-p 'concat insn) (comp-tests-mentioned-p 'length insn))))) -(ert-deftest comp-tests-fw-prop () +(comp-deftest fw-prop () "Some tests for forward propagation." (let ((comp-speed 2) (comp-post-pass-hooks '((comp-final comp-tests-fw-prop-checker-1)))) @@ -717,7 +726,7 @@ CHECKER should always return nil to have a pass." (comp-tests-mentioned-p (comp-c-func-name 'comp-tests-pure-fibn-f "F" t) insn))))) -(ert-deftest comp-tests-pure () +(comp-deftest pure () "Some tests for pure functions optimization." (let ((comp-speed 3) (comp-post-pass-hooks '((comp-final comp-tests-pure-checker-1 commit ddf1b1931c7072d83d7b114a191fad92bb1000b4 Author: Andrea Corallo Date: Thu Oct 1 18:04:00 2020 +0200 * test/src/comp-tests.el (comp-tests-bootstrap): Tag it as expensive. diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 356bd876ff..f76afdbf1c 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -46,6 +46,7 @@ (ert-deftest comp-tests-bootstrap () "Compile the compiler and load it to compile it-self. Check that the resulting binaries do not differ." + :tags '(:expensive-test) (let* ((comp-src (concat comp-test-directory "../../lisp/emacs-lisp/comp.el")) (comp1-src (make-temp-file "stage1-" nil ".el")) commit 2cc82563d288f5fa1bf1f763eae7934320d40014 Author: Andrea Corallo Date: Thu Oct 1 07:55:00 2020 +0200 * lisp/emacs-lisp/comp.el (comp-c-func-name): Add autoload cookie. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index dec5c8ec41..02b08119f9 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -598,6 +598,8 @@ instruction." (or (comp-spill-decl-spec function-name 'speed) comp-speed)) +;; Autoloaded as might by used by `disassemble-internal'. +;;;###autoload (defun comp-c-func-name (name prefix &optional first) "Given NAME return a name suitable for the native code. Add PREFIX in front of it. If FIRST is not nil pick the first commit ec23b719e5350f70f731060bca04d5b23887f08c Author: Andrea Corallo Date: Wed Sep 30 16:53:32 2020 +0200 * Improve some docstring in src/comp.c * src/comp.c (Fcomp_el_to_eln_filename) (Fcomp__compile_ctxt_to_file): Improve docstring. (Fcomp__compile_ctxt_to_file): Rename 'file_name' -> 'filename'. (Fnative_comp_available_p): Improve docstring. diff --git a/src/comp.c b/src/comp.c index 0b42582ab2..058ce7e96a 100644 --- a/src/comp.c +++ b/src/comp.c @@ -4015,7 +4015,7 @@ static Lisp_Object loadsearch_re_list; DEFUN ("comp-el-to-eln-filename", Fcomp_el_to_eln_filename, Scomp_el_to_eln_filename, 1, 2, 0, - doc: /* Given a source file return the corresponding .eln true filename. + doc: /* Given a source FILENAME return the corresponding .eln filename. If BASE-DIR is nil use the first entry in `comp-eln-load-path'. */) (Lisp_Object filename, Lisp_Object base_dir) { @@ -4363,13 +4363,13 @@ restore_sigmask (void) DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, Scomp__compile_ctxt_to_file, 1, 1, 0, - doc: /* Compile as native code the current context to file. */) - (Lisp_Object file_name) + doc: /* Compile as native code the current context to file FILENAME. */) + (Lisp_Object filename) { load_gccjit_if_necessary (true); - CHECK_STRING (file_name); - Lisp_Object base_name = Fsubstring (file_name, Qnil, make_fixnum (-4)); + CHECK_STRING (filename); + Lisp_Object base_name = Fsubstring (filename, Qnil, make_fixnum (-4)); gcc_jit_context_set_int_option (comp.ctxt, GCC_JIT_INT_OPTION_OPTIMIZATION_LEVEL, @@ -4441,16 +4441,16 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, if (err) xsignal3 (Qnative_ice, build_string ("failed to compile"), - file_name, + filename, build_string (err)); - CALL1I (comp-clean-up-stale-eln, file_name); - CALL2I (comp-delete-or-replace-file, file_name, tmp_file); + CALL1I (comp-clean-up-stale-eln, filename); + CALL2I (comp-delete-or-replace-file, filename, tmp_file); if (!noninteractive) unbind_to (count, Qnil); - return file_name; + return filename; } DEFUN ("comp-libgccjit-version", Fcomp_libgccjit_version, @@ -5068,7 +5068,7 @@ DEFUN ("native-elisp-load", Fnative_elisp_load, Snative_elisp_load, 1, 2, 0, DEFUN ("native-comp-available-p", Fnative_comp_available_p, Snative_comp_available_p, 0, 0, 0, doc: /* Returns t if native compilation of Lisp files is available in -this instance of Emacs. */) +this instance of Emacs, nil otherwise. */) (void) { #ifdef HAVE_NATIVE_COMP commit 86e37ea8c5c758b6d22308104755a396816d8768 Author: Andrea Corallo Date: Wed Sep 30 15:19:18 2020 +0200 * .gitlab-ci.yml: Uncomment some testing to align with master. diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 93929f211c..e5ebd6a92a 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -37,58 +37,55 @@ before_script: stages: - test -# FIXME: Commented for this branch till is known to be broken. -# test-all: -# # This tests also file monitor libraries inotify and inotifywatch. -# stage: test -# only: -# changes: -# - "Makefile.in" -# - .gitlab-ci.yml -# - aclocal.m4 -# - autogen.sh -# - configure.ac -# - lib/*.{h,c} -# - lisp/*.el -# - lisp/**/*.el -# - src/*.{h,c} -# - test/lisp/*.el -# - test/lisp/**/*.el -# - test/src/*.el -# except: -# changes: -# # gfilemonitor, kqueue -# - src/gfilenotify.c -# - src/kqueue.c -# # MS Windows -# - lisp/w32*.el -# - lisp/term/w32*.el -# - src/w32*.{h,c} -# # GNUstep -# - lisp/term/ns-win.el -# - src/ns*.{h,m} -# - src/macfont.{h,m} -# script: -# - DEBIAN_FRONTEND=noninteractive apt install --no-install-recommends -y -qq -o=Dpkg::Use-Pty=0 inotify-tools -# - ./autogen.sh autoconf -# - ./configure --without-makeinfo -# - make bootstrap -# - make check-expensive +test-all: + # This tests also file monitor libraries inotify and inotifywatch. + stage: test + only: + changes: + - "Makefile.in" + - .gitlab-ci.yml + - aclocal.m4 + - autogen.sh + - configure.ac + - lib/*.{h,c} + - lisp/*.el + - lisp/**/*.el + - src/*.{h,c} + - test/lisp/*.el + - test/lisp/**/*.el + - test/src/*.el + except: + changes: + # gfilemonitor, kqueue + - src/gfilenotify.c + - src/kqueue.c + # MS Windows + - lisp/w32*.el + - lisp/term/w32*.el + - src/w32*.{h,c} + # GNUstep + - lisp/term/ns-win.el + - src/ns*.{h,m} + - src/macfont.{h,m} + script: + - DEBIAN_FRONTEND=noninteractive apt install --no-install-recommends -y -qq -o=Dpkg::Use-Pty=0 inotify-tools + - ./autogen.sh autoconf + - ./configure --without-makeinfo + - make bootstrap + - make check-expensive test-filenotify-gio: stage: test # This tests file monitor libraries gfilemonitor and gio. - - ## Commented to keep stock bootstrap tested. - # only: - # changes: - # - .gitlab-ci.yml - # - lisp/autorevert.el - # - lisp/filenotify.el - # - lisp/net/tramp-sh.el - # - src/gfilenotify.c - # - test/lisp/autorevert-tests.el - # - test/lisp/filenotify-tests.el + only: + changes: + - .gitlab-ci.yml + - lisp/autorevert.el + - lisp/filenotify.el + - lisp/net/tramp-sh.el + - src/gfilenotify.c + - test/lisp/autorevert-tests.el + - test/lisp/filenotify-tests.el script: - DEBIAN_FRONTEND=noninteractive apt install --no-install-recommends -y -qq -o=Dpkg::Use-Pty=0 libglib2.0-dev libglib2.0-bin libglib2.0-0 - ./autogen.sh autoconf commit 6eb5a8c49295a132d341c04fad6998b293930eb6 Merge: 89f064104c 6c0f1c26d2 Author: Andrea Corallo Date: Wed Sep 30 09:09:39 2020 +0200 Merge remote-tracking branch 'savannah/master' into clean-up commit 89f064104c25f8b4362ef54d28fd4bce18f6af3b Author: Andrea Corallo Date: Mon Sep 28 21:09:00 2020 +0200 * Some clean-up in comp.el * lisp/emacs-lisp/comp.el (comp-emit-cond-jump, comp-emit-switch) (comp-limplify-block, comp-compute-edges) (comp-ssa-rename, comp-fwprop*, comp-effective-async-max-jobs) (comp-run-async-workers): Respect max 80 columns. (batch-byte-native-compile-for-bootstrap): Improve doc + remove some now unnecessary error handling. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index e1438fbb2f..dec5c8ec41 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -973,8 +973,9 @@ block. If NEGATED non null negate the tested condition. Return value is the fall through block name." (cl-destructuring-bind (label-num . label-sp) lap-label - (let* ((bb (comp-block-name (comp-bb-maybe-add (1+ (comp-limplify-pc comp-pass)) - (comp-sp)))) ; Fall through block. + (let* ((bb (comp-block-name (comp-bb-maybe-add + (1+ (comp-limplify-pc comp-pass)) + (comp-sp)))) ; Fall through block. (target-sp (+ target-offset (comp-sp))) (target-addr (comp-label-to-addr label-num)) (target (comp-bb-maybe-add target-addr target-sp)) @@ -1065,8 +1066,9 @@ Return value is the fall through block name." for n from 1 for last = (= n len) for m-test = (make-comp-mvar :constant test) - for target-name = (comp-block-name (comp-bb-maybe-add (comp-label-to-addr target-label) - (comp-sp))) + for target-name = (comp-block-name (comp-bb-maybe-add + (comp-label-to-addr target-label) + (comp-sp))) for ff-bb = (if last (comp-bb-maybe-add (1+ (comp-limplify-pc comp-pass)) (comp-sp)) @@ -1562,7 +1564,9 @@ into the C code forwarding the compilation unit." (let* ((stack-depth (if label-sp (1- label-sp) (comp-sp))) - (next-bb (comp-block-name (comp-bb-maybe-add (comp-limplify-pc comp-pass) stack-depth)))) + (next-bb (comp-block-name (comp-bb-maybe-add + (comp-limplify-pc comp-pass) + stack-depth)))) (unless (comp-block-closed bb) (comp-emit `(jump ,next-bb)))) (cl-return))) @@ -1733,14 +1737,17 @@ into the C code forwarding the compilation unit." (list "block does not end with a branch" bb (comp-func-name comp-func))))) - finally (setf (comp-func-edges comp-func) - (nreverse (comp-func-edges comp-func))) - ;; Update edge refs into blocks. - (cl-loop for edge in (comp-func-edges comp-func) - do (push edge - (comp-block-out-edges (comp-edge-src edge))) - (push edge - (comp-block-in-edges (comp-edge-dst edge)))) + finally + (setf (comp-func-edges comp-func) + (nreverse (comp-func-edges comp-func))) + ;; Update edge refs into blocks. + (cl-loop + for edge in (comp-func-edges comp-func) + do + (push edge + (comp-block-out-edges (comp-edge-src edge))) + (push edge + (comp-block-in-edges (comp-edge-dst edge)))) (comp-log-edges comp-func)))) (defun comp-collect-rev-post-order (basic-block) @@ -1932,10 +1939,11 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non-nil." (setf (comp-block-final-frame bb) (copy-sequence in-frame)) (when-let ((out-edges (comp-block-out-edges bb))) - (cl-loop for ed in out-edges - for child = (comp-edge-dst ed) - ;; Provide a copy of the same frame to all childs. - do (ssa-rename-rec child (copy-sequence in-frame))))))) + (cl-loop + for ed in out-edges + for child = (comp-edge-dst ed) + ;; Provide a copy of the same frame to all children. + do (ssa-rename-rec child (copy-sequence in-frame))))))) (ssa-rename-rec (gethash 'entry (comp-func-blocks comp-func)) (comp-new-frame frame-size t))))) @@ -2118,7 +2126,8 @@ Return t if something was changed." (cl-loop with modified = nil for b being each hash-value of (comp-func-blocks comp-func) do (cl-loop for insn in (comp-block-insns b) - for orig-insn = (unless modified ; Save consing after 1th change. + for orig-insn = (unless modified + ;; Save consing after 1th change. (comp-copy-insn insn)) do (comp-fwprop-insn insn) when (and (null modified) (not (equal insn orig-insn))) @@ -2689,9 +2698,11 @@ processes from `comp-async-compilations'" ;; the number of processors, see get_native_system_info in w32.c. ;; The result needs to be exported to Lisp. (max 1 (/ (cond ((eq 'windows-nt system-type) - (string-to-number (getenv "NUMBER_OF_PROCESSORS"))) + (string-to-number (getenv + "NUMBER_OF_PROCESSORS"))) ((executable-find "nproc") - (string-to-number (shell-command-to-string "nproc"))) + (string-to-number + (shell-command-to-string "nproc"))) (t 1)) 2)))) comp-async-jobs-number)) @@ -2712,8 +2723,8 @@ display a message." when (or comp-always-compile load ; Always compile when the compilation is ; commanded for late load. - (file-newer-than-file-p source-file - (comp-el-to-eln-filename source-file))) + (file-newer-than-file-p + source-file (comp-el-to-eln-filename source-file))) do (let* ((expr `(progn (require 'comp) (setf comp-speed ,comp-speed @@ -2841,21 +2852,18 @@ Ultra cheap impersonation of `batch-byte-compile'." ;;;###autoload (defun batch-byte-native-compile-for-bootstrap () "As `batch-byte-compile' but used for booststrap. -Always generate elc files too and handle native compiler expected errors." +Generate .elc files in addition to the .eln one. If the +environment variable 'NATIVE_DISABLED' is set byte compile only." (comp-ensure-native-compiler) (if (equal (getenv "NATIVE_DISABLED") "1") (batch-byte-compile) (cl-assert (= 1 (length command-line-args-left))) (let ((byte-native-for-bootstrap t) (byte-to-native-output-file nil)) - (unwind-protect - (condition-case _ - (batch-native-compile) - (native-compiler-error-dyn-func) - (native-compiler-error-empty-byte)) - (pcase byte-to-native-output-file - (`(,tempfile . ,target-file) - (rename-file tempfile target-file t))))))) + (batch-native-compile) + (pcase byte-to-native-output-file + (`(,tempfile . ,target-file) + (rename-file tempfile target-file t)))))) ;;;###autoload (defun native-compile-async (paths &optional recursively load) @@ -2874,7 +2882,8 @@ LOAD can be nil t or 'late." (dolist (path paths) (cond ((file-directory-p path) (dolist (file (if recursively - (directory-files-recursively path comp-valid-source-re) + (directory-files-recursively + path comp-valid-source-re) (directory-files path t comp-valid-source-re))) (push file files))) ((file-exists-p path) (push path files)) commit 3129b3ffcb85be4acd1284616675025104d3c661 Author: Andrea Corallo Date: Mon Sep 28 21:09:00 2020 +0200 Rename in docstrings "non nil" into "non-nil" * lisp/emacs-lisp/comp.el: Rename non nil -> non-nil in doc. * src/comp.c: Likewise. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index cac63a5978..e1438fbb2f 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -139,7 +139,7 @@ and above." :group 'comp) (defvar comp-dry-run nil - "When non nil run everything but the C back-end.") + "When non-nil run everything but the C back-end.") (defconst comp-valid-source-re (rx ".el" (? ".gz") eos) "Regexp to match filename of valid input source files.") @@ -271,7 +271,7 @@ This is tipically for top-level forms other than defun.") (d-ephemeral (make-comp-data-container) :type comp-data-container :documentation "Relocated data not necessary after load.") (with-late-load nil :type boolean - :documentation "When non nil support late load.")) + :documentation "When non-nil support late load.")) (cl-defstruct comp-args-base (min nil :type number @@ -321,7 +321,7 @@ Is in use to help the SSA rename pass.")) "A basic block created from lap." ;; These two slots are used during limplification. (sp nil :type number - :documentation "When non nil indicates the sp value while entering + :documentation "When non-nil indicates the sp value while entering into it.") (addr nil :type number :documentation "Start block LAP address.")) @@ -407,10 +407,10 @@ structure.") (const-vld nil :type boolean :documentation "Valid signal for the following slot.") (constant nil - :documentation "When const-vld non nil this is used for holding + :documentation "When const-vld non-nil this is used for holding a value known at compile time.") (type nil :type symbol - :documentation "When non nil indicates the type when known at compile + :documentation "When non-nil indicates the type when known at compile time.")) ;; Special vars used by some passes @@ -881,7 +881,7 @@ STACK-OFF is the index of the first slot frame involved." (defun comp-new-frame (size &optional ssa) "Return a clean frame of meta variables of size SIZE. -If SSA non nil populate it of m-var in ssa form." +If SSA non-nil populate it of m-var in ssa form." (cl-loop with v = (make-vector size nil) for i below size for mvar = (if ssa @@ -1490,7 +1490,7 @@ These are stored in the reloc data array." (defun comp-limplify-top-level (for-late-load) "Create a limple function to modify the global environment at load. -When FOR-LATE-LOAD is non nil the emitted function modifies only +When FOR-LATE-LOAD is non-nil the emitted function modifies only function definition. Synthesize a function called 'top_level_run' that gets one single @@ -1876,7 +1876,7 @@ into the C code forwarding the compilation unit." (defun comp-dom-tree-walker (bb pre-lambda post-lambda) "Dominator tree walker function starting from basic block BB. -PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non nil." +PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non-nil." (when pre-lambda (funcall pre-lambda bb)) (when-let ((out-edges (comp-block-out-edges bb))) @@ -2043,7 +2043,7 @@ Forward propagate immediate involed in assignments." (comp-mvar-type lval) (comp-mvar-type rval))) (defsubst comp-function-optimizable-p (f args) - "Given function F called with ARGS return non nil when optimizable." + "Given function F called with ARGS return non-nil when optimizable." (and (cl-every #'comp-mvar-const-vld args) (comp-function-pure-p f))) diff --git a/src/comp.c b/src/comp.c index 15782ccb16..0b42582ab2 100644 --- a/src/comp.c +++ b/src/comp.c @@ -5019,7 +5019,7 @@ file_in_eln_sys_dir (Lisp_Object filename) /* Load related routines. */ DEFUN ("native-elisp-load", Fnative_elisp_load, Snative_elisp_load, 1, 2, 0, doc: /* Load native elisp code FILENAME. - LATE_LOAD has to be non nil when loading for deferred + LATE_LOAD has to be non-nil when loading for deferred compilation. */) (Lisp_Object filename, Lisp_Object late_load) { commit bb2a334a2061222ac1e701b557e5ce6dc0dad941 Author: Andrea Corallo Date: Mon Sep 28 21:09:00 2020 +0200 * src/lisp.h: Remove a newline diff left over master. diff --git a/src/lisp.h b/src/lisp.h index e33577b563..a1bdfe89d3 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -4735,6 +4735,7 @@ extern bool profiler_memory_running; extern void malloc_probe (size_t); extern void syms_of_profiler (void); + #ifdef DOS_NT /* Defined in msdos.c, w32.c. */ extern char *emacs_root_dir (void); commit a06fe08e8e8177ae3ccd6e2677b40237cd86ae9d Author: Andrea Corallo Date: Mon Sep 28 17:20:55 2020 +0200 Clean-up some now unnecessary diff against master * lisp/emacs-lisp/autoload.el (update-directory-autoloads): .eln files have been moved so remove the '.eln' match. * lisp/emacs-lisp/bytecomp.el (byte-compile-refresh-preloaded): Likewise. * lisp/emacs-lisp/find-func.el (find-library-suffixes): Clean-up as '.eln' is no more in `load-suffixes'. * lisp/help-fns.el (find-lisp-object-file-name): Clean-up as `symbol-file' will return the '.elc' file. * src/lread.c (Fget_load_suffixes): Remove logic as '.eln' is not anymore in load-suffixes. (openp): Two spaces. diff --git a/lisp/emacs-lisp/autoload.el b/lisp/emacs-lisp/autoload.el index 4bdbc95081..5ee0a14273 100644 --- a/lisp/emacs-lisp/autoload.el +++ b/lisp/emacs-lisp/autoload.el @@ -1047,7 +1047,7 @@ write its autoloads into the specified file instead." ;; we don't want to depend on whether Emacs was ;; built with or without modules support, nor ;; what is the suffix for the underlying OS. - (unless (string-match "\\.\\(elc\\|eln\\|so\\|dll\\)" suf) + (unless (string-match "\\.\\(elc\\|so\\|dll\\)" suf) (push suf tmp))) (concat "\\`[^=.].*" (regexp-opt tmp t) "\\'"))) (files (apply #'nconc diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 4a2a8c62cb..b0e3158df3 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -5180,8 +5180,7 @@ Use with caution." (message "Can't find %s to refresh preloaded Lisp files" argv0) (dolist (f (reverse load-history)) (setq f (car f)) - (when (string-match "el[cn]\\'" f) - (setq f (substring f 0 -1))) + (if (string-match "elc\\'" f) (setq f (substring f 0 -1))) (when (and (file-readable-p f) (file-newer-than-file-p f emacs-file) ;; Don't reload the source version of the files below diff --git a/lisp/emacs-lisp/find-func.el b/lisp/emacs-lisp/find-func.el index a4577a5316..9e4d8cf1aa 100644 --- a/lisp/emacs-lisp/find-func.el +++ b/lisp/emacs-lisp/find-func.el @@ -167,8 +167,7 @@ See the functions `find-function' and `find-variable'." (defun find-library-suffixes () (let ((suffixes nil)) (dolist (suffix (get-load-suffixes) (nreverse suffixes)) - (unless (string-match "el[cn]" suffix) - (push suffix suffixes))))) + (unless (string-match "elc" suffix) (push suffix suffixes))))) (defun find-library--load-name (library) (let ((name library)) diff --git a/lisp/help-fns.el b/lisp/help-fns.el index 88984ec453..9fee156f18 100644 --- a/lisp/help-fns.el +++ b/lisp/help-fns.el @@ -323,17 +323,12 @@ found via `load-path'. The return value can also be `C-source', which means that OBJECT is a function or variable defined in C. If no suitable file is found, return nil." (let* ((autoloaded (autoloadp type)) - (true-name (or (and autoloaded (nth 1 type)) + (file-name (or (and autoloaded (nth 1 type)) (symbol-file ;; FIXME: Why do we have this weird "If TYPE is the ;; value returned by `symbol-function' for a function ;; symbol" exception? - object (or (if (symbolp type) type) 'defun)))) - (file-name (if (and true-name - (string-match "[.]eln\\'" true-name)) - (gethash (file-name-nondirectory true-name) - comp-eln-to-el-h) - true-name))) + object (or (if (symbolp type) type) 'defun))))) (cond (autoloaded ;; An autoloaded function: Locate the file since `symbol-function' @@ -392,7 +387,7 @@ suitable file is found, return nil." ((let ((lib-name (if (string-match "[.]elc\\'" file-name) (substring-no-properties file-name 0 -1) - file-name))) + file-name))) (or (and (file-readable-p lib-name) lib-name) ;; The library might be compressed. (and (file-readable-p (concat lib-name ".gz")) lib-name)))) diff --git a/src/lread.c b/src/lread.c index d32f5755e9..ea31131b75 100644 --- a/src/lread.c +++ b/src/lread.c @@ -1056,25 +1056,8 @@ This uses the variables `load-suffixes' and `load-file-rep-suffixes'. */) { Lisp_Object exts = Vload_file_rep_suffixes; Lisp_Object suffix = XCAR (suffixes); - bool native_code_suffix = - NATIVE_COMP_FLAG - && strcmp (NATIVE_ELISP_SUFFIX, SSDATA (suffix)) == 0; - -#ifdef HAVE_MODULES - native_code_suffix = - native_code_suffix || strcmp (MODULES_SUFFIX, SSDATA (suffix)) == 0; -#ifdef MODULES_SECONDARY_SUFFIX - native_code_suffix = - native_code_suffix - || strcmp (MODULES_SECONDARY_SUFFIX, SSDATA (suffix)) == 0; -#endif -#endif - - if (native_code_suffix) - lst = Fcons (suffix, lst); - else - FOR_EACH_TAIL (exts) - lst = Fcons (concat2 (suffix, XCAR (exts)), lst); + FOR_EACH_TAIL (exts) + lst = Fcons (concat2 (suffix, XCAR (exts)), lst); } return Fnreverse (lst); } @@ -1698,6 +1681,7 @@ openp (Lisp_Object path, Lisp_Object str, Lisp_Object suffixes, int last_errno = ENOENT; int save_fd = -1; USE_SAFE_ALLOCA; + /* The last-modified time of the newest matching file found. Initialize it to something less than all valid timestamps. */ struct timespec save_mtime = make_timespec (TYPE_MINIMUM (time_t), -1); @@ -1898,7 +1882,6 @@ openp (Lisp_Object path, Lisp_Object str, Lisp_Object suffixes, /* We succeeded; return this descriptor and filename. */ if (storeptr) *storeptr = string; - SAFE_FREE (); return fd; } commit dc0cf16c7a60f36aafcf9b56513a855cefa7e1ad Author: Andrea Corallo Date: Sat Sep 26 15:12:30 2020 +0200 Always set 'Vexec_path' before 'Vinvocation_directory' (bug#43137) Do this as depending on the OS if argv0 is not populated 'Vexec_path' is used to infer 'Vinvocation_directory'. * src/pdumper.c (pdumper_load): Invoke 'init_vars_for_load' instead of 'set_invocation_vars'. * src/lisp.h: Extern 'init_vars_for_load' instead of 'set_invocation_vars' . * src/emacs.c (set_invocation_vars): Make it static and remove double invocation guard. (init_vars_for_load): Wrap 'init_callproc_1' and 'set_invocation_vars' calls + add double invocation guard. (init_cmdargs): Move out 'set_invocation_vars' invocation. (main): Call 'init_vars_for_load' instead of 'init_callproc_1'. diff --git a/src/emacs.c b/src/emacs.c index 07e40fdc8b..1f7f5eabc5 100644 --- a/src/emacs.c +++ b/src/emacs.c @@ -413,16 +413,9 @@ terminate_due_to_signal (int sig, int backtrace_limit) /* Set `invocation-name' `invocation-directory'. */ -void +static void set_invocation_vars (char *argv0, char const *original_pwd) { - /* This function can be called from within pdumper or later during - boot. No need to run it twice. */ - static bool double_run_guard; - if (double_run_guard) - return; - double_run_guard = true; - Lisp_Object raw_name, handler; AUTO_STRING (slash_colon, "/:"); @@ -480,6 +473,25 @@ set_invocation_vars (char *argv0, char const *original_pwd) } } +/* Initialize a number of variables (ultimately + 'Vinvocation_directory') needed by pdumper to complete native code + load. */ + +void +init_vars_for_load (char *argv0, char const *original_pwd) +{ + /* This function is called from within pdumper while loading (as + soon as we are able to allocate) or later during boot if pdumper + is not used. No need to run it twice. */ + static bool double_run_guard; + if (double_run_guard) + return; + double_run_guard = true; + + init_callproc_1 (); /* Must precede init_cmdargs and init_sys_modes. */ + set_invocation_vars (argv0, original_pwd); +} + /* Code for dealing with Lisp access to the Unix command line. */ static void @@ -492,8 +504,6 @@ init_cmdargs (int argc, char **argv, int skip_args, char const *original_pwd) initial_argv = argv; initial_argc = argc; - set_invocation_vars (argv[0], original_pwd); - Vinstallation_directory = Qnil; if (!NILP (Vinvocation_directory)) @@ -1788,7 +1798,7 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem /* Init buffer storage and default directory of main buffer. */ init_buffer (); - init_callproc_1 (); /* Must precede init_cmdargs and init_sys_modes. */ + init_vars_for_load (argv[0], original_pwd); /* Must precede init_lread. */ init_cmdargs (argc, argv, skip_args, original_pwd); diff --git a/src/lisp.h b/src/lisp.h index 452f48f346..e33577b563 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -4430,7 +4430,7 @@ extern bool display_arg; extern Lisp_Object decode_env_path (const char *, const char *, bool); extern Lisp_Object empty_unibyte_string, empty_multibyte_string; extern AVOID terminate_due_to_signal (int, int); -extern void set_invocation_vars (char *argv0, char const *original_pwd); +extern void init_vars_for_load (char *, char const *); #ifdef WINDOWSNT extern Lisp_Object Vlibrary_cache; #endif diff --git a/src/pdumper.c b/src/pdumper.c index 0a7e0388f1..03391c4950 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -5587,7 +5587,8 @@ pdumper_load (const char *dump_filename, char *argv0, char const *original_pwd) /* Once we can allocate and before loading .eln files we must set Vinvocation_directory (.eln paths are relative to it). */ - set_invocation_vars (argv0, original_pwd); + init_vars_for_load (argv0, original_pwd); + dump_do_all_dump_reloc_for_phase (header, dump_base, LATE_RELOCS); dump_do_all_dump_reloc_for_phase (header, dump_base, VERY_LATE_RELOCS); initialized = true; commit 29a8d9303bd3098eed88f3eb7394b66ae28cc887 Author: Andrea Corallo Date: Sat Sep 26 14:28:36 2020 +0200 * lisp/emacs-lisp/cl-macs.el (cl--optimize): Add a FIXME. diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index e7c7374976..9c41374fc7 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -2359,6 +2359,8 @@ Example: (defun foo (x) (declare (cl-optimize (speed 3) (safety 0))) x)" + ;; FIXME this should make use of `cl--declare-stack' but I suspect + ;; this mechanism should be reviewed first. (cl-loop for (qly val) in qualities do (cl-ecase qly (speed commit 06acf681d6fd8e2c5c6a9584b5df6b98eccda20b Merge: e5b052d60d e00936bf9f Author: Andrea Corallo Date: Sat Sep 26 15:31:50 2020 +0200 Merge remote-tracking branch 'savannah/master' into HEAD commit e5b052d60d905209c6cefcf18c620167ed946301 Author: Andrea Corallo Date: Wed Sep 23 22:01:45 2020 +0200 Rename comp--subr-safe-advice -> comp-subr-safe-advice * lisp/emacs-lisp/comp.el (comp-subr-safe-advice): Rename comp--subr-safe-advice -> comp-subr-safe-advice. * lisp/emacs-lisp/nadvice.el (advice--add-function): Likewise. * lisp/emacs-lisp/advice.el (ad-add-advice): Likewise. diff --git a/lisp/emacs-lisp/advice.el b/lisp/emacs-lisp/advice.el index 4c19197024..4df8743de5 100644 --- a/lisp/emacs-lisp/advice.el +++ b/lisp/emacs-lisp/advice.el @@ -2076,7 +2076,7 @@ If FUNCTION was not advised already, its advice info will be initialized. Redefining a piece of advice whose name is part of the cache-id will clear the cache." (when (subr-primitive-p (symbol-function function)) - (comp--subr-safe-advice function)) + (comp-subr-safe-advice function)) (cond ((not (ad-is-advised function)) (ad-initialize-advice-info function) (ad-set-advice-info-field diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 07b0ccee3c..cac63a5978 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2595,7 +2595,7 @@ Return the its filename if found or nil otherwise." comp-native-version-dir))))) ;;;###autoload -(defun comp--subr-safe-advice (subr-name) +(defun comp-subr-safe-advice (subr-name) "Make SUBR-NAME effectively advice-able when called from native code." (unless (or (memq subr-name comp-never-optimize-functions) (gethash subr-name comp-installed-trampolines-h)) diff --git a/lisp/emacs-lisp/nadvice.el b/lisp/emacs-lisp/nadvice.el index 32b5df8f26..5b3aa70850 100644 --- a/lisp/emacs-lisp/nadvice.el +++ b/lisp/emacs-lisp/nadvice.el @@ -333,7 +333,7 @@ is also interactive. There are 3 cases: ;; Must require explicitly as during bootstrap we have no ;; autoloads. (require 'comp) - (comp--subr-safe-advice subr-name)))) + (comp-subr-safe-advice subr-name)))) (let* ((name (cdr (assq 'name props))) (a (advice--member-p (or name function) (if name t) (gv-deref ref)))) (when a commit 6d83902ffd0c50a3157c4c61cd636433b212f709 Author: Andrea Corallo Date: Wed Sep 23 21:50:20 2020 +0200 * lisp/emacs-lisp/comp.el (comp-body-eff): Improve style. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 8b8b111640..07b0ccee3c 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1127,13 +1127,9 @@ When BODY is auto guess function name form the LAP byte-code name. Otherwise expect lname fnname." (pcase (car body) ('auto - (list `(comp-emit-set-call-subr - ',(comp-op-to-fun op-name) - ,sp-delta))) + `((comp-emit-set-call-subr ',(comp-op-to-fun op-name) ,sp-delta))) ((pred symbolp) - (list `(comp-emit-set-call-subr - ',(car body) - ,sp-delta))) + `((comp-emit-set-call-subr ',(car body) ,sp-delta))) (_ body)))) (defmacro comp-op-case (&rest cases) commit 94736c413ff728833f260acf125ff3a572e270d6 Author: Andrea Corallo Date: Wed Sep 23 21:56:52 2020 +0200 Do not install a subr trampoline twice * src/comp.c (syms_of_comp): Define and initialize 'Vcomp_installed_trampolines_h'. (Fcomp__install_trampoline): Fill 'Vcomp_installed_trampolines_h' * lisp/emacs-lisp/comp.el (comp--subr-safe-advice): Make use of `comp-installed-trampolines-h' to guard against installing a trampoline twice. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index e33d58cb40..8b8b111640 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2601,7 +2601,8 @@ Return the its filename if found or nil otherwise." ;;;###autoload (defun comp--subr-safe-advice (subr-name) "Make SUBR-NAME effectively advice-able when called from native code." - (unless (memq subr-name comp-never-optimize-functions) + (unless (or (memq subr-name comp-never-optimize-functions) + (gethash subr-name comp-installed-trampolines-h)) (let ((trampoline-sym (comp-trampoline-sym subr-name))) (cl-assert (subr-primitive-p (symbol-function subr-name))) (load (or (comp-search-trampoline subr-name) diff --git a/src/comp.c b/src/comp.c index db6aee9d7b..15782ccb16 100644 --- a/src/comp.c +++ b/src/comp.c @@ -4126,6 +4126,7 @@ DEFUN ("comp--install-trampoline", Fcomp__install_trampoline, if (EQ (subr, orig_subr)) { freloc.link_table[i] = XSUBR (trampoline)->function.a0; + Fputhash (subr_name, Qt, Vcomp_installed_trampolines_h); return Qt; } i++; @@ -5257,6 +5258,10 @@ The last directory of this list is assumed to be the system one. */); dump reload. */ Vcomp_eln_load_path = Fcons (build_string ("../native-lisp/"), Qnil); + DEFVAR_LISP ("comp-installed-trampolines-h", Vcomp_installed_trampolines_h, + doc: /* Hash table subr-name -> bool. */); + Vcomp_installed_trampolines_h = CALLN (Fmake_hash_table); + #endif /* #ifdef HAVE_NATIVE_COMP */ defsubr (&Snative_comp_available_p); commit b94a0a931ee7963515c009e7e683e907897567bb Author: Andrea Corallo Date: Wed Sep 23 09:50:01 2020 +0200 * lisp/emacs-lisp/comp.el (comp-never-optimize-functions): Clean-up. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index f6c6748b74..e33d58cb40 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -94,17 +94,11 @@ Skip if any is matching." :group 'comp) (defcustom comp-never-optimize-functions - '(;; Mandatory for Emacs to be working correctly - macroexpand scroll-down scroll-up narrow-to-region widen rename-buffer - make-indirect-buffer delete-file top-level abort-recursive-edit - ;; For user convenience - yes-or-no-p - ;; Make the Evil happy :/ - read-key-sequence select-window set-window-buffer split-window-internal - use-global-map use-local-map) - "Primitive functions for which we do not perform trampoline optimization. -This is especially useful for primitives known to be advised or -redefined when compilation is performed at `comp-speed' > 0." + '(;; The following two are mandatory for Emacs to be working + ;; correctly (see comment in `advice--add-function'). DO NOT + ;; REMOVE. + macroexpand rename-buffer) + "Primitive functions for which we do not perform trampoline optimization." :type 'list :group 'comp) commit 0cc1804d42e25e0213f8b3872cc6133c6480a5b0 Author: Andrea Corallo Date: Wed Sep 23 09:36:49 2020 +0200 Add a test for primitive advicing effectiveness * test/src/comp-test-funcs.el (comp-test-primitive-advice-f): New function. * test/src/comp-tests.el (comp-test-primitive-advice): New test. diff --git a/test/src/comp-test-funcs.el b/test/src/comp-test-funcs.el index fe9943a1b9..19acec2716 100644 --- a/test/src/comp-test-funcs.el +++ b/test/src/comp-test-funcs.el @@ -337,6 +337,10 @@ (concat head-padding (substring str from-idx idx) tail-padding ellipsis))))) +(defun comp-test-primitive-advice-f (x y) + (declare (speed 2)) + (+ x y)) + ;;;;;;;;;;;;;;;;;;;; ;; Tromey's tests ;; diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 220bf1c773..356bd876ff 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -375,6 +375,19 @@ https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-03/msg00914.html." (should (string= (comp-test-42360-f "Nel mezzo del " 18 0 32 "yyy" nil) "Nel mezzo del yyy"))) +(defvar comp-test-primitive-advice) +(ert-deftest comp-test-primitive-advice () + "Test effectiveness of primitve advicing." + (let (comp-test-primitive-advice + (f (lambda (&rest args) + (setq comp-test-primitive-advice args)))) + (advice-add #'+ :before f) + (unwind-protect + (progn + (should (= (comp-test-primitive-advice-f 3 4) 7)) + (should (equal comp-test-primitive-advice '(3 4)))) + (advice-remove #'+ f)))) + ;;;;;;;;;;;;;;;;;;;;; ;; Tromey's tests. ;; commit db354ffd578a46d898cac161ea1de1b42f96d2a0 Author: Andrea Corallo Date: Sat Sep 19 22:33:34 2020 +0200 Call `comp--subr-safe-advice' from the advice machinery * lisp/emacs-lisp/nadvice.el (advice--add-function): Call `comp--subr-safe-advice' when necessary. * lisp/emacs-lisp/advice.el (ad-add-advice): Likewhise. diff --git a/lisp/emacs-lisp/advice.el b/lisp/emacs-lisp/advice.el index 0ebd2741d2..4c19197024 100644 --- a/lisp/emacs-lisp/advice.el +++ b/lisp/emacs-lisp/advice.el @@ -2075,6 +2075,8 @@ mapped to the closest extremal position). If FUNCTION was not advised already, its advice info will be initialized. Redefining a piece of advice whose name is part of the cache-id will clear the cache." + (when (subr-primitive-p (symbol-function function)) + (comp--subr-safe-advice function)) (cond ((not (ad-is-advised function)) (ad-initialize-advice-info function) (ad-set-advice-info-field diff --git a/lisp/emacs-lisp/nadvice.el b/lisp/emacs-lisp/nadvice.el index b779aa2788..32b5df8f26 100644 --- a/lisp/emacs-lisp/nadvice.el +++ b/lisp/emacs-lisp/nadvice.el @@ -318,6 +318,22 @@ is also interactive. There are 3 cases: ;;;###autoload (defun advice--add-function (where ref function props) + (when (and (boundp 'comp-ctxt) + (subr-primitive-p (gv-deref ref))) + (let ((subr-name (intern (subr-name (gv-deref ref))))) + ;; Requiring the native compiler to advice `macroexpand' cause a + ;; circular dependency in eager macro expansion. + ;; uniquify is advising `rename-buffer' while being loaded in + ;; loadup.el. This would require the whole native compiler + ;; machinery but we don't want to include it in the dump. + ;; Because these two functions are already handled in + ;; `comp-never-optimize-functions' we hack the problem this way + ;; for now :/ + (unless (memq subr-name '(macroexpand rename-buffer)) + ;; Must require explicitly as during bootstrap we have no + ;; autoloads. + (require 'comp) + (comp--subr-safe-advice subr-name)))) (let* ((name (cdr (assq 'name props))) (a (advice--member-p (or name function) (if name t) (gv-deref ref)))) (when a commit 3ec1b932c9c57d200c3a3f2fb9a0c59c4acc8011 Author: Andrea Corallo Date: Sat Sep 19 14:52:50 2020 +0200 * Add `comp--subr-safe-advice' entry point Add a Lisp side entry-point to be called to make primitive adivicing effective. * lisp/emacs-lisp/comp.el (comp-trampoline-sym) (comp-trampoline-filename): New substs. (comp-make-lambda-list-from-subr, comp-search-trampoline) (comp-tampoline-compile): New functions diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 2bba298ac0..f6c6748b74 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2542,6 +2542,81 @@ Prepare every function for final compilation and drive the C back-end." (declare (gv-setter (lambda (val) `(setf ,x ,val)))) x) + +;; Primitive funciton advice machinery + +(defsubst comp-trampoline-sym (subr-name) + "Given SUBR-NAME return the trampoline function name." + (intern (concat "--subr-trampoline-" (symbol-name subr-name)))) + +(defsubst comp-trampoline-filename (subr-name) + "Given SUBR-NAME return the filename containing the trampoline." + (concat (comp-c-func-name subr-name "subr-trampoline-" t) ".eln")) + +(defun comp-make-lambda-list-from-subr (subr) + "Given SUBR return the equivalent lambda-list." + (pcase-let ((`(,min . ,max) (subr-arity subr)) + (lambda-list '())) + (cl-loop repeat min + do (push (gensym "arg") lambda-list)) + (if (numberp max) + (cl-loop + initially (push '&optional lambda-list) + repeat (- max min) + do (push (gensym "arg") lambda-list)) + (push '&rest lambda-list) + (push (gensym "arg") lambda-list)) + (reverse lambda-list))) + +(defun comp-search-trampoline (subr-name) + "Search a trampoline file for SUBR-NAME. +Return the its filename if found or nil otherwise." + (cl-loop + with rel-filename = (comp-trampoline-filename subr-name) + for dir in comp-eln-load-path + for filename = (expand-file-name rel-filename + (concat dir comp-native-version-dir)) + when (file-exists-p filename) + do (cl-return filename))) + +(defun comp-tampoline-compile (subr-name) + "Synthesize and compile a trampoline for SUBR-NAME and return its filename." + (let ((trampoline-sym (comp-trampoline-sym subr-name)) + (lambda-list (comp-make-lambda-list-from-subr + (symbol-function subr-name))) + ;; Use speed 0 to maximize compilation speed and not to + ;; optimize away funcall calls! + (byte-optimize nil) + (comp-speed 0)) + ;; The synthesized trampoline must expose the exact same ABI of + ;; the primitive we are replacing in the function reloc table. + (defalias trampoline-sym + `(closure nil ,lambda-list + (let ((f #',subr-name)) + (,(if (memq '&rest lambda-list) 'apply 'funcall) + f + ,@(cl-loop + for arg in lambda-list + unless (memq arg '(&optional &rest)) + collect arg))))) + (native-compile trampoline-sym nil + (expand-file-name (comp-trampoline-filename subr-name) + (concat (car comp-eln-load-path) + comp-native-version-dir))))) + +;;;###autoload +(defun comp--subr-safe-advice (subr-name) + "Make SUBR-NAME effectively advice-able when called from native code." + (unless (memq subr-name comp-never-optimize-functions) + (let ((trampoline-sym (comp-trampoline-sym subr-name))) + (cl-assert (subr-primitive-p (symbol-function subr-name))) + (load (or (comp-search-trampoline subr-name) + (comp-tampoline-compile subr-name)) + nil t) + (cl-assert + (subr-native-elisp-p (symbol-function trampoline-sym))) + (comp--install-trampoline subr-name (symbol-function trampoline-sym))))) + ;; Some entry point support code. commit 2f78ac32bbef78155e2f52e73d60f7b46fc8afea Author: Andrea Corallo Date: Sat Sep 19 16:44:53 2020 +0200 * Add `comp--install-trampoline' machinery * src/comp.c (Fcomp__install_trampoline): New function to install a subr trampoline into the function relocation table. Once this is done any call from native compiled Lisp to the related primitive will go through the `funcall' trampoline making advicing effective. diff --git a/src/comp.c b/src/comp.c index 63a58be264..db6aee9d7b 100644 --- a/src/comp.c +++ b/src/comp.c @@ -4102,6 +4102,39 @@ If BASE-DIR is nil use the first entry in `comp-eln-load-path'. */) concat2 (base_dir, Vcomp_native_version_dir)); } +DEFUN ("comp--install-trampoline", Fcomp__install_trampoline, + Scomp__install_trampoline, 2, 2, 0, + doc: /* Install a TRAMPOLINE for primitive SUBR-NAME. */) + (Lisp_Object subr_name, Lisp_Object trampoline) +{ + CHECK_SYMBOL (subr_name); + CHECK_SUBR (trampoline); + Lisp_Object orig_subr = Fsymbol_function (subr_name); + CHECK_SUBR (orig_subr); + + /* FIXME: add a post dump load trampoline machinery to remove this + check. */ + if (will_dump_p ()) + signal_error ("Trying to advice unexpected primitive before dumping", + subr_name); + + Lisp_Object subr_l = Vcomp_subr_list; + ptrdiff_t i = ARRAYELTS (helper_link_table); + FOR_EACH_TAIL (subr_l) + { + Lisp_Object subr = XCAR (subr_l); + if (EQ (subr, orig_subr)) + { + freloc.link_table[i] = XSUBR (trampoline)->function.a0; + return Qt; + } + i++; + } + signal_error ("Trying to install trampoline for non existent subr", + subr_name); + return Qnil; +} + DEFUN ("comp--init-ctxt", Fcomp__init_ctxt, Scomp__init_ctxt, 0, 0, 0, doc: /* Initialize the native compiler context. Return t on success. */) @@ -5162,6 +5195,7 @@ native compiled one. */); defsubr (&Scomp_el_to_eln_filename); defsubr (&Scomp_native_driver_options_effective_p); + defsubr (&Scomp__install_trampoline); defsubr (&Scomp__init_ctxt); defsubr (&Scomp__release_ctxt); defsubr (&Scomp__compile_ctxt_to_file); commit 2ab0966b2fdf3a64d061727f005d32c5aad27594 Author: Andrea Corallo Date: Sat Sep 19 16:13:56 2020 +0200 Make CHECK_SUBR public * src/data.c (CHECK_SUBR): Move from here to... * src/lisp.h (CHECK_SUBR): ...to here. diff --git a/src/data.c b/src/data.c index 3f035269de..8c39c31911 100644 --- a/src/data.c +++ b/src/data.c @@ -87,12 +87,6 @@ XOBJFWD (lispfwd a) return a.fwdptr; } -static void -CHECK_SUBR (Lisp_Object x) -{ - CHECK_TYPE (SUBRP (x), Qsubrp, x); -} - static void set_blv_found (struct Lisp_Buffer_Local_Value *blv, int found) { diff --git a/src/lisp.h b/src/lisp.h index cbc6a66647..452f48f346 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -2982,6 +2982,12 @@ CHECK_INTEGER (Lisp_Object x) { CHECK_TYPE (INTEGERP (x), Qnumberp, x); } + +INLINE void +CHECK_SUBR (Lisp_Object x) +{ + CHECK_TYPE (SUBRP (x), Qsubrp, x); +} /* If we're not dumping using the legacy dumper and we might be using commit 9d4fd669cf9b97a89e8d1481b3ffedfe7a455152 Author: Andrea Corallo Date: Wed Sep 23 20:48:23 2020 +0200 * lisp/emacs-lisp/comp.el (comp-final): Log when interactively invoked. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index d4f003f771..2bba298ac0 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2516,12 +2516,14 @@ Prepare every function for final compilation and drive the C back-end." (with-temp-file temp-file (insert (prin1-to-string expr))) (with-temp-buffer - (if (zerop - (call-process (expand-file-name invocation-name - invocation-directory) - nil t t "--batch" "-l" temp-file)) - output - (signal 'native-compiler-error (buffer-string))))))) + (unwind-protect + (if (zerop + (call-process (expand-file-name invocation-name + invocation-directory) + nil t t "--batch" "-l" temp-file)) + output + (signal 'native-compiler-error (buffer-string))) + (comp-log-to-buffer (buffer-string))))))) ;;; Compiler type hints. commit 63c65b4fe0e27b70a99463a8f7de4750811fd1e0 Author: Andrea Corallo Date: Sat Sep 19 12:31:03 2020 +0200 * lisp/emacs-lisp/comp.el (native-compile): Add OUTPUT parameter. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 4795d2fc07..d4f003f771 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2709,13 +2709,14 @@ display a message." ;;; Compiler entry points. ;;;###autoload -(defun native-compile (function-or-file &optional with-late-load) +(defun native-compile (function-or-file &optional with-late-load output) "Compile FUNCTION-OR-FILE into native code. This is the entry-point for the Emacs Lisp native compiler. FUNCTION-OR-FILE is a function symbol or a path to an Elisp file. -When WITH-LATE-LOAD non Nil mark the compilation unit for late load +When WITH-LATE-LOAD non-nil mark the compilation unit for late load once finished compiling (internal use only). -Return the compilation unit file name." +When OUTPUT is non-nil use it as filename for the compiled object. +Return the compile object filename." (comp-ensure-native-compiler) (unless (or (functionp function-or-file) (stringp function-or-file)) @@ -2727,11 +2728,15 @@ Return the compilation unit file name." (byte-compile-debug t) (comp-ctxt (make-comp-ctxt - :output (if (symbolp function-or-file) - (make-temp-file (symbol-name function-or-file) nil ".eln") - (comp-el-to-eln-filename function-or-file - (when byte-native-for-bootstrap - (car (last comp-eln-load-path))))) + :output (or (when output + (expand-file-name output)) + (if (symbolp function-or-file) + (make-temp-file (symbol-name function-or-file) nil + ".eln") + (comp-el-to-eln-filename + function-or-file + (when byte-native-for-bootstrap + (car (last comp-eln-load-path)))))) :with-late-load with-late-load))) (comp-log "\n \n" 1) (condition-case err commit 4a50f541447eddefcca3ebc6bedb110ac0041f90 Author: Andrea Corallo Date: Mon Sep 21 21:07:04 2020 +0200 * Fix MacOS Emacs.app installation (bug#43532) * src/comp.c (Fcomp_el_to_eln_filename): Adapt the filename hashing algorithm to allow for producing a MacOS self-contained Emacs.app. diff --git a/src/comp.c b/src/comp.c index 15d85d30fc..63a58be264 100644 --- a/src/comp.c +++ b/src/comp.c @@ -4054,18 +4054,30 @@ If BASE-DIR is nil use the first entry in `comp-eln-load-path'. */) if (NILP (loadsearch_re_list)) { - Lisp_Object loadsearch_list = - Fcons (build_string (PATH_DUMPLOADSEARCH), - Fcons (build_string (PATH_LOADSEARCH), Qnil)); - FOR_EACH_TAIL (loadsearch_list) - loadsearch_re_list = - Fcons (Fregexp_quote (XCAR (loadsearch_list)), loadsearch_re_list); + Lisp_Object sys_re; +#ifdef __APPLE__ + /* On MacOS we relax the match on PATH_LOADSEARCH making + everything before ".app/" a wildcard. This to obtain a + self-contained Emacs.app (bug#43532). */ + char *c; + if ((c = strstr (PATH_LOADSEARCH, ".app/"))) + sys_re = + concat2 (build_string ("\\`[[:ascii:]]+"), + Fregexp_quote (build_string (c))); + else + sys_re = Fregexp_quote (build_string (PATH_LOADSEARCH)); +#else + sys_re = Fregexp_quote (build_string (PATH_LOADSEARCH)); +#endif + loadsearch_re_list = + list2 (sys_re, Fregexp_quote (build_string (PATH_DUMPLOADSEARCH))); } - Lisp_Object loadsearch_res = loadsearch_re_list; - FOR_EACH_TAIL (loadsearch_res) + + Lisp_Object lds_re_tail = loadsearch_re_list; + FOR_EACH_TAIL (lds_re_tail) { Lisp_Object match_idx = - Fstring_match (XCAR (loadsearch_res), filename, Qnil); + Fstring_match (XCAR (lds_re_tail), filename, Qnil); if (EQ (match_idx, make_fixnum (0))) { filename = commit 89a2e79b7d9fa9dc640951bbb3cb0d78dbfbc310 Author: Andrea Corallo Date: Sat Sep 19 22:42:16 2020 +0200 * Make use of use of `subr-primitive-p' in `find-function-library' * lisp/emacs-lisp/find-func.el (find-function-library): Use `subr-primitive-p'. diff --git a/lisp/emacs-lisp/find-func.el b/lisp/emacs-lisp/find-func.el index f5f8c82208..a4577a5316 100644 --- a/lisp/emacs-lisp/find-func.el +++ b/lisp/emacs-lisp/find-func.el @@ -432,7 +432,7 @@ message about the whole chain of aliases." (cons function (cond ((autoloadp def) (nth 1 def)) - ((and (subrp def) (not (subr-native-elisp-p def))) + ((subr-primitive-p def) (if lisp-only (error "%s is a built-in function" function)) (help-C-file-name def 'subr)) commit 69c32e01875f33ba1cc4ad37d0940375cd0c6e27 Author: Andrea Corallo Date: Sat Sep 19 10:27:41 2020 +0200 * Sandbox syncronous libgccjit invocation on interactive sessions Avoid unnecessary memory fragmentation/leakeage * lisp/emacs-lisp/comp.el (comp-final1): New function. (comp-final): Invoke `comp-final1' in a child process if in an interactive session or directly otherwhise. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 25e2de9d5d..4795d2fc07 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2475,8 +2475,7 @@ Prepare every function for final compilation and drive the C back-end." (unless comp-dry-run (comp--compile-ctxt-to-file name)))) -(defun comp-final (_) - "Final pass driving the C back-end for code emission." +(defun comp-final1 () (let (compile-result) (comp--init-ctxt) (unwind-protect @@ -2485,6 +2484,45 @@ Prepare every function for final compilation and drive the C back-end." (and (comp--release-ctxt) compile-result)))) +(defun comp-final (_) + "Final pass driving the C back-end for code emission." + (if noninteractive + (comp-final1) + ;; Call comp-final1 in a child process. + (let* ((output (comp-ctxt-output comp-ctxt)) + (print-escape-newlines t) + (print-length nil) + (print-level nil) + (print-quoted t) + (print-gensym t) + (print-circle t) + (expr `(progn + (require 'comp) + (setf comp-speed ,comp-speed + comp-debug ,comp-debug + comp-verbose ,comp-verbose + comp-ctxt ,comp-ctxt + comp-eln-load-path ',comp-eln-load-path + comp-native-driver-options + ',comp-native-driver-options + load-path ',load-path) + ,comp-async-env-modifier-form + (message "Compiling %s..." ',output) + (comp-final1))) + (temp-file (make-temp-file + (concat "emacs-int-comp-" + (file-name-base output) "-") + nil ".el"))) + (with-temp-file temp-file + (insert (prin1-to-string expr))) + (with-temp-buffer + (if (zerop + (call-process (expand-file-name invocation-name + invocation-directory) + nil t t "--batch" "-l" temp-file)) + output + (signal 'native-compiler-error (buffer-string))))))) + ;;; Compiler type hints. ;; Public entry points to be used by user code to give comp commit 5a8be1719a80031ea3833749b1e82de8d5a39787 Merge: 5b41545f1b fb68645b5a Author: Andrea Corallo Date: Mon Sep 21 21:45:02 2020 +0200 Merge remote-tracking branch 'savannah/master' into HEAD commit 5b41545f1be367837d9ac717ea67fba19a4c24d4 Author: Andrea Corallo Date: Tue Sep 15 09:05:14 2020 +0200 * Better error handling after calling 'gcc_jit_context_compile_to_file' Tipically errors are catched in 'compile_function' but in case libgccjit throw an error only afterwards while compiling the whole compilation unit we have to report it correctly. * src/comp.c (Fcomp__compile_ctxt_to_file): Catch libgccjit errors after calling 'gcc_jit_context_compile_to_file'. diff --git a/src/comp.c b/src/comp.c index b3640b5e37..15d85d30fc 100644 --- a/src/comp.c +++ b/src/comp.c @@ -4391,6 +4391,13 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, GCC_JIT_OUTPUT_KIND_DYNAMIC_LIBRARY, SSDATA (tmp_file)); + const char *err = gcc_jit_context_get_first_error (comp.ctxt); + if (err) + xsignal3 (Qnative_ice, + build_string ("failed to compile"), + file_name, + build_string (err)); + CALL1I (comp-clean-up-stale-eln, file_name); CALL2I (comp-delete-or-replace-file, file_name, tmp_file); commit 5f37c18581ea1a36e9dcb5d4ac741aafb0398ebe Author: Andrea Corallo Date: Mon Sep 14 22:59:41 2020 +0200 * test/src/comp-tests.el (comp-tests-bootstrap): Print compilation time. diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index b147bd6789..220bf1c773 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -58,11 +58,15 @@ Check that the resulting binaries do not differ." (load (concat comp-src "c") nil nil t t)) (should-not (subr-native-elisp-p (symbol-function #'native-compile))) (message "Compiling stage1...") - (let ((comp1-eln (native-compile comp1-src))) + (let* ((t0 (current-time)) + (comp1-eln (native-compile comp1-src))) + (message "Done in %d secs" (float-time (time-since t0))) (load comp1-eln nil nil t t) (should (subr-native-elisp-p (symbol-function 'native-compile))) (message "Compiling stage2...") - (let ((comp2-eln (native-compile comp2-src))) + (let ((t0 (current-time)) + (comp2-eln (native-compile comp2-src))) + (message "Done in %d secs" (float-time (time-since t0))) (message "Comparing %s %s" comp1-eln comp2-eln) (should (= (call-process "cmp" nil nil nil comp1-eln comp2-eln) 0)))))) commit e9728375763c61e3b890530b202b856d28c44646 Author: Andrea Corallo Date: Mon Sep 14 22:50:21 2020 +0200 * Fix free function compilation load process. * lisp/emacs-lisp/comp.el (comp-clean-up-stale-eln): Do not crash if the eln filename is not canonical (tmp file or manual load). diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index f1689808ee..25e2de9d5d 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2509,17 +2509,18 @@ Prepare every function for final compilation and drive the C back-end." (defun comp-clean-up-stale-eln (file) "Given FILE remove all the .eln files in `comp-eln-load-path' sharing the original source filename (including FILE)." - (string-match (rx "-" (group-n 1 (1+ hex)) "-" (1+ hex) ".eln" eos) file) - (cl-loop - with filename-hash = (match-string 1 file) - with regexp = (rx-to-string - `(seq "-" ,filename-hash "-" (1+ hex) ".eln" eos)) - for dir in (butlast comp-eln-load-path) ; Skip last dir. - do (cl-loop - with full-dir = (concat dir comp-native-version-dir) - for f in (when (file-exists-p full-dir) - (directory-files full-dir t regexp t)) - do (comp-delete-or-replace-file f)))) + (when (string-match (rx "-" (group-n 1 (1+ hex)) "-" (1+ hex) ".eln" eos) + file) + (cl-loop + with filename-hash = (match-string 1 file) + with regexp = (rx-to-string + `(seq "-" ,filename-hash "-" (1+ hex) ".eln" eos)) + for dir in (butlast comp-eln-load-path) ; Skip last dir. + do (cl-loop + with full-dir = (concat dir comp-native-version-dir) + for f in (when (file-exists-p full-dir) + (directory-files full-dir t regexp t)) + do (comp-delete-or-replace-file f))))) (defun comp-delete-or-replace-file (oldfile &optional newfile) "Replace OLDFILE with NEWFILE. commit 82171a8f0de6e88566aa0d80388dab135dbc260f Author: Andrea Corallo Date: Mon Sep 14 22:02:36 2020 +0200 * Add gv-setters for compiler hints * lisp/emacs-lisp/comp.el (comp-hint-fixnum, comp-hint-cons): Add gv-setters so type hinted expressions can be used as places. Read we can now have like: '(cl-incf (cl-the fixnum x))'. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index eceba777fa..f1689808ee 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2495,9 +2495,11 @@ Prepare every function for final compilation and drive the C back-end." ;; are assumed just to be true. Use with extreme caution... (defun comp-hint-fixnum (x) + (declare (gv-setter (lambda (val) `(setf ,x ,val)))) x) (defun comp-hint-cons (x) + (declare (gv-setter (lambda (val) `(setf ,x ,val)))) x) commit 2da2ad29b83090950749f26a7375be4a67964438 Author: Andrea Corallo Date: Mon Sep 14 22:02:18 2020 +0200 * lisp/emacs-lisp/comp.el (comp-sp): Better style gv-setter declaration. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 831af3793e..eceba777fa 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -810,9 +810,9 @@ Points to the next slot to be filled.") (defsubst comp-sp () "Current stack pointer." + (declare (gv-setter (lambda (val) + `(setf (comp-limplify-sp comp-pass) ,val)))) (comp-limplify-sp comp-pass)) -(gv-define-setter comp-sp (value) - `(setf (comp-limplify-sp comp-pass) ,value)) (defmacro comp-with-sp (sp &rest body) "Execute BODY setting the stack pointer to SP. commit a3dc11e9ccd48beb84adfe79ff28143c1682f690 Author: Andrea Corallo Date: Mon Sep 14 21:27:26 2020 +0200 * Remove type check emission from type hints low level primitives These have to be emitted by higher level primitves as `cl-the'. * lisp/emacs-lisp/comp.el (comp-hint-fixnum, comp-hint-cons): Do not emit type checks. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index e1920dbc03..831af3793e 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2487,20 +2487,18 @@ Prepare every function for final compilation and drive the C back-end." ;;; Compiler type hints. -;; These are public entry points be used in user code to give comp suggestion -;; about types. -;; These can be used to implement CL style 'the', 'declare' or something like. +;; Public entry points to be used by user code to give comp +;; suggestions about types. These are used to implement CL style +;; `cl-the' and hopefully parameter type declaration. ;; Note: types will propagates. ;; WARNING: At speed >= 2 type checking is not performed anymore and suggestions ;; are assumed just to be true. Use with extreme caution... (defun comp-hint-fixnum (x) - (unless (fixnump x) - (signal 'wrong-type-argument x))) + x) (defun comp-hint-cons (x) - (unless (consp x) - (signal 'wrong-type-argument x))) + x) ;; Some entry point support code. commit c9a9b0766f43d1acf56e2ff19eb9505b454423a0 Author: Andrea Corallo Date: Mon Sep 14 21:22:19 2020 +0200 * lisp/emacs-lisp/cl-macs.el: Define fixnum and bignum. Define fixnum so `cl-typep' recognize it and the type check emitted by `cl-the' is effective. diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index 2730e8f24a..e7c7374976 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -3437,6 +3437,10 @@ The type name can then be used in `cl-typecase', `cl-check-type', etc." (cl-function (lambda (&cl-defs ('*) ,@arglist) ,@body))))) (cl-deftype extended-char () '(and character (not base-char))) +;; Define fixnum so `cl-typep' recognize it and the type check emitted +;; by `cl-the' is effective. +(cl-deftype fixnum () 'fixnump) +(cl-deftype bignum () 'bignump) ;;; Additional functions that we can now define because we've defined ;;; `cl-defsubst' and `cl-typep'. commit 95312717c726e390de26bd85341a17b163b40fd7 Author: Andrea Corallo Date: Mon Sep 14 21:06:54 2020 +0200 * Add 'cl-optimize' as function declaration * lisp/emacs-lisp/cl-macs.el: Register cl-optimize into `defun-declarations-alist' and `macro-declarations-alist'. (cl--optimize): New function to serve 'cl-optimize' declaration. diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index 7adb910070..2730e8f24a 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -2347,6 +2347,26 @@ values. For compatibility, (cl-values A B C) is a synonym for (list A B C). (list ',type ,temp ',form))) ,temp)))) +;;;###autoload +(or (assq 'cl-optimize defun-declarations-alist) + (let ((x (list 'cl-optimize #'cl--optimize))) + (push x macro-declarations-alist) + (push x defun-declarations-alist))) + +(defun cl--optimize (f _args &rest qualities) + "Serve 'cl-optimize' in function declarations. +Example: +(defun foo (x) + (declare (cl-optimize (speed 3) (safety 0))) + x)" + (cl-loop for (qly val) in qualities + do (cl-ecase qly + (speed + (setf cl--optimize-speed val) + (byte-run--set-speed f nil val)) + (safety + (setf cl--optimize-safety val))))) + (defvar cl--proclaim-history t) ; for future compilers (defvar cl--declare-stack t) ; for future compilers commit c4cc13917cdf733b142ed2dee9b5aee9df9f8153 Author: Andrea Corallo Date: Tue Sep 1 21:28:22 2020 +0200 * lisp/emacs-lisp/cl-macs.el (cl-the): Emit compiler hints when native. diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index c38019d4a7..7adb910070 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -2329,6 +2329,14 @@ values. For compatibility, (cl-values A B C) is a synonym for (list A B C). (defmacro cl-the (type form) "Return FORM. If type-checking is enabled, assert that it is of TYPE." (declare (indent 1) (debug (cl-type-spec form))) + ;; When native compiling possibly add the appropriate type hint. + (when (and (boundp 'byte-native-compiling) + byte-native-compiling) + (setf form + (cl-case type + (fixnum `(comp-hint-fixnum ,form)) + (cons `(comp-hint-cons ,form)) + (otherwise form)))) (if (not (or (not (cl--compiling-file)) (< cl--optimize-speed 3) (= cl--optimize-safety 3))) commit 21021e56ad609a459ec117bcfc60b2802176a9a7 Author: Andrea Corallo Date: Sun Sep 13 18:15:32 2020 +0200 * Fix defsbust declare effectiveness introduced by 80d7f710 (Bug#43280). * lisp/emacs-lisp/byte-run.el (defsubst): Do not add a speed declaration as this breaks a pre existing ones if present but rather calls directly `byte-run--set-speed'. diff --git a/lisp/emacs-lisp/byte-run.el b/lisp/emacs-lisp/byte-run.el index 8c16c172be..df693ab1c8 100644 --- a/lisp/emacs-lisp/byte-run.el +++ b/lisp/emacs-lisp/byte-run.el @@ -363,13 +363,12 @@ You don't need this. (See bytecomp.el commentary for more details.) (or (memq (get name 'byte-optimizer) '(nil byte-compile-inline-expand)) (error "`%s' is a primitive" name)) + ;; Never native-compile defsubsts as we need the byte + ;; definition in `byte-compile-unfold-bcf' to perform the + ;; inlining (Bug#42664). + (byte-run--set-speed name nil -1) `(prog1 - (defun ,name ,arglist - ;; Never native-compile defsubsts as we need the byte - ;; definition in `byte-compile-unfold-bcf' to perform the - ;; inlining (Bug#42664). - (declare (speed -1)) - ,@body) + (defun ,name ,arglist ,@body) (eval-and-compile (put ',name 'byte-optimizer 'byte-compile-inline-expand)))) commit 6a726c5ad711ba5224319c6ff8787127a8289c6d Merge: c55884d72a 99af480d00 Author: Andrea Corallo Date: Sun Sep 13 18:20:21 2020 +0200 Merge remote-tracking branch 'savannah/master' into HEAD commit c55884d72a4ea806a97c9925d6f85adcca89a3bd Author: Andrea Corallo Date: Fri Sep 11 14:57:11 2020 +0200 * src/comp.c (emit_static_object): Make use of ARRAYELTS. diff --git a/src/comp.c b/src/comp.c index 1ef4f3054b..b3640b5e37 100644 --- a/src/comp.c +++ b/src/comp.c @@ -2549,7 +2549,7 @@ emit_static_object (const char *name, Lisp_Object obj) gcc_jit_context_new_struct_type (comp.ctxt, NULL, format_string ("%s_struct", name), - 2, fields)); + ARRAYELTS (fields), fields)); gcc_jit_lvalue *data_struct = gcc_jit_context_new_global (comp.ctxt, commit ff593d934aec6d8e7b211d7fe2ff7fc8f92ad42b Author: Andrea Corallo Date: Sun May 31 14:39:59 2020 +0100 * Make use of new 'gcc_jit_global_set_initializer' entry point Use this brand new entry point to avoid the current workaround and its load-time memcpys. * src/comp.c (gcc_jit_global_set_initializer): Add to the dynamic load machinery. (static_obj_t): Remove const qualifier from the data field. (emit_static_object): Make use of 'gcc_jit_global_set_initializer' when available. (load_static_obj): Use the blob for loading if that was emitted. diff --git a/src/comp.c b/src/comp.c index d7966d4222..1ef4f3054b 100644 --- a/src/comp.c +++ b/src/comp.c @@ -90,6 +90,7 @@ along with GNU Emacs. If not, see . */ #undef gcc_jit_function_get_param #undef gcc_jit_function_new_block #undef gcc_jit_function_new_local +#undef gcc_jit_global_set_initializer #undef gcc_jit_lvalue_access_field #undef gcc_jit_lvalue_as_rvalue #undef gcc_jit_lvalue_get_address @@ -144,6 +145,8 @@ DEF_DLL_FN (gcc_jit_lvalue *, gcc_jit_context_new_global, DEF_DLL_FN (gcc_jit_lvalue *, gcc_jit_function_new_local, (gcc_jit_function *func, gcc_jit_location *loc, gcc_jit_type *type, const char *name)); +DEF_DLL_FN (gcc_jit_lvalue *, gcc_jit_global_set_initializer, + (gcc_jit_lvalue *global, const void *blob, size_t num_bytes)); DEF_DLL_FN (gcc_jit_lvalue *, gcc_jit_lvalue_access_field, (gcc_jit_lvalue *struct_or_union, gcc_jit_location *loc, gcc_jit_field *field)); @@ -307,6 +310,7 @@ init_gccjit_functions (void) LOAD_DLL_FN (library, gcc_jit_struct_set_fields); LOAD_DLL_FN (library, gcc_jit_type_get_pointer); LOAD_DLL_FN_OPT (library, gcc_jit_context_add_driver_option); + LOAD_DLL_FN_OPT (library, gcc_jit_global_set_initializer); LOAD_DLL_FN_OPT (library, gcc_jit_version_major); LOAD_DLL_FN_OPT (library, gcc_jit_version_minor); LOAD_DLL_FN_OPT (library, gcc_jit_version_patchlevel); @@ -357,6 +361,7 @@ init_gccjit_functions (void) #define gcc_jit_function_get_param fn_gcc_jit_function_get_param #define gcc_jit_function_new_block fn_gcc_jit_function_new_block #define gcc_jit_function_new_local fn_gcc_jit_function_new_local +#define gcc_jit_global_set_initializer fn_gcc_jit_global_set_initializer #define gcc_jit_lvalue_access_field fn_gcc_jit_lvalue_access_field #define gcc_jit_lvalue_as_rvalue fn_gcc_jit_lvalue_as_rvalue #define gcc_jit_lvalue_get_address fn_gcc_jit_lvalue_get_address @@ -589,7 +594,7 @@ FILE *logfile = NULL; /* This is used for serialized objects by the reload mechanism. */ typedef struct { ptrdiff_t len; - const char data[]; + char data[]; } static_obj_t; typedef struct { @@ -2497,6 +2502,33 @@ emit_static_object (const char *name, Lisp_Object obj) ptrdiff_t len = SBYTES (str); const char *p = SSDATA (str); +#if defined (LIBGCCJIT_HAVE_gcc_jit_global_set_initializer) \ + || defined (WINDOWSNT) +#pragma GCC diagnostic ignored "-Waddress" + if (gcc_jit_global_set_initializer) +#pragma GCC diagnostic pop + { + ptrdiff_t str_size = len + 1; + ptrdiff_t size = sizeof (static_obj_t) + str_size; + static_obj_t *static_obj = xmalloc (size); + static_obj->len = str_size; + memcpy (static_obj->data, p, str_size); + gcc_jit_lvalue *blob = + gcc_jit_context_new_global ( + comp.ctxt, + NULL, + GCC_JIT_GLOBAL_EXPORTED, + gcc_jit_context_new_array_type (comp.ctxt, NULL, + comp.char_type, + size), + format_string ("%s_blob", name)); + gcc_jit_global_set_initializer (blob, static_obj, size); + xfree (static_obj); + + return; + } +#endif + gcc_jit_type *a_type = gcc_jit_context_new_array_type (comp.ctxt, NULL, @@ -4599,12 +4631,19 @@ typedef char *(*comp_lit_str_func) (void); static Lisp_Object load_static_obj (struct Lisp_Native_Comp_Unit *comp_u, const char *name) { + static_obj_t *blob = + dynlib_sym (comp_u->handle, format_string ("%s_blob", name)); + if (blob) + /* New blob format. */ + return Fread (make_string (blob->data, blob->len)); + static_obj_t *(*f)(void) = dynlib_sym (comp_u->handle, name); if (!f) xsignal1 (Qnative_lisp_file_inconsistent, comp_u->file); - static_obj_t *res = f (); - return Fread (make_string (res->data, res->len)); + blob = f (); + return Fread (make_string (blob->data, blob->len)); + } /* Return false when something is wrong or true otherwise. */ commit 42b5a1101d2230bc1a6d7abf019f9a96c164da5c Author: Andrea Corallo Date: Fri Sep 11 11:12:32 2020 +0200 * Update gitlab CI yml file * .gitlab-ci.yml (test-native-bootstrap-speed0) (test-native-bootstrap-speed1, test-native-bootstrap-speed2): Update for new make invokation. diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 6627f5f805..93929f211c 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -107,7 +107,7 @@ test-native-bootstrap-speed0: - DEBIAN_FRONTEND=noninteractive apt install --no-install-recommends -y -qq -o=Dpkg::Use-Pty=0 libgccjit-6-dev - ./autogen.sh autoconf - ./configure --without-makeinfo --with-nativecomp - - make bootstrap BYTE_COMPILE_EXTRA_FLAGS='--eval "(setq comp-speed 0)"' -j2 + - make bootstrap NATIVE_FULL_AOT=1 BYTE_COMPILE_EXTRA_FLAGS='--eval "(setq comp-speed 0)"' -j2 timeout: 8 hours test-native-bootstrap-speed1: @@ -116,7 +116,7 @@ test-native-bootstrap-speed1: - DEBIAN_FRONTEND=noninteractive apt install --no-install-recommends -y -qq -o=Dpkg::Use-Pty=0 libgccjit-6-dev - ./autogen.sh autoconf - ./configure --without-makeinfo --with-nativecomp - - make bootstrap NATIVE_FAST_BOOT=1 BYTE_COMPILE_EXTRA_FLAGS='--eval "(setq comp-speed 1)"' + - make bootstrap BYTE_COMPILE_EXTRA_FLAGS='--eval "(setq comp-speed 1)"' timeout: 8 hours test-native-bootstrap-speed2: @@ -125,7 +125,7 @@ test-native-bootstrap-speed2: - DEBIAN_FRONTEND=noninteractive apt install --no-install-recommends -y -qq -o=Dpkg::Use-Pty=0 libgccjit-6-dev - ./autogen.sh autoconf - ./configure --without-makeinfo --with-nativecomp - - make bootstrap NATIVE_FAST_BOOT=1 + - make bootstrap timeout: 8 hours test-gnustep: commit 3c58403b0f9b732e045230ce34f1b5a8460630ac Author: Andrea Corallo Date: Fri Sep 11 10:51:39 2020 +0200 By default when building native compile only what's part of the dump image To Ahead of Time compile the whole Emacs distro define NATIVE_FULL_AOT when invoking make ex: 'make NATIVE_FULL_AOT=1'. * lisp/Makefile.in (NATIVE_SKIP_NONDUMP): New variable. (compile-main): Use it + rename NATIVE_DISABLE -> NATIVE_DISABLED. * lisp/emacs-lisp/comp.el (batch-byte-native-compile-for-bootstrap): Rename NATIVE_DISABLE -> NATIVE_DISABLED. diff --git a/lisp/Makefile.in b/lisp/Makefile.in index 164e4a01f5..75563adeee 100644 --- a/lisp/Makefile.in +++ b/lisp/Makefile.in @@ -38,6 +38,9 @@ AM_V_ELC = $(am__v_ELC_@AM_V@) am__v_ELC_ = $(am__v_ELC_@AM_DEFAULT_V@) ifeq ($(HAVE_NATIVE_COMP),yes) am__v_ELC_0 = @echo " ELC+ELN " $@; +ifndef NATIVE_FULL_AOT +NATIVE_SKIP_NONDUMP = 1 +endif else am__v_ELC_0 = @echo " ELC " $@; endif @@ -353,7 +356,7 @@ compile-main: gen-lisp compile-clean done | xargs $(XARGS_LIMIT) echo) | \ while read chunk; do \ $(MAKE) compile-targets \ - NATIVE_DISABLE=$(NATIVE_FAST_BOOT) \ + NATIVE_DISABLED=$(NATIVE_SKIP_NONDUMP) \ TARGETS="$$chunk"; \ done diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index cfc5ca5548..e1920dbc03 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2731,7 +2731,7 @@ Ultra cheap impersonation of `batch-byte-compile'." "As `batch-byte-compile' but used for booststrap. Always generate elc files too and handle native compiler expected errors." (comp-ensure-native-compiler) - (if (equal (getenv "NATIVE_DISABLE") "1") + (if (equal (getenv "NATIVE_DISABLED") "1") (batch-byte-compile) (cl-assert (= 1 (length command-line-args-left))) (let ((byte-native-for-bootstrap t) commit cb293cfb929dfbecb3057dde2115399b89350a9b Author: Andrea Corallo Date: Thu Sep 10 09:59:29 2020 +0200 * Guard against trying to rename files into eln sys directory * src/comp.c (file_in_eln_sys_dir): New function. (Fnative_elisp_load): Make use of. diff --git a/src/comp.c b/src/comp.c index 4550833a6a..d7966d4222 100644 --- a/src/comp.c +++ b/src/comp.c @@ -4912,6 +4912,18 @@ DEFUN ("comp--late-register-subr", Fcomp__late_register_subr, return Qnil; } +static bool +file_in_eln_sys_dir (Lisp_Object filename) +{ + Lisp_Object eln_sys_dir = Qnil; + Lisp_Object tmp = Vcomp_eln_load_path; + FOR_EACH_TAIL (tmp) + eln_sys_dir = XCAR (tmp); + return !NILP (Fstring_match (Fregexp_quote (Fexpand_file_name (eln_sys_dir, + Qnil)), + Fexpand_file_name (filename, Qnil), Qnil)); +} + /* Load related routines. */ DEFUN ("native-elisp-load", Fnative_elisp_load, Snative_elisp_load, 1, 2, 0, doc: /* Load native elisp code FILENAME. @@ -4926,6 +4938,7 @@ DEFUN ("native-elisp-load", Fnative_elisp_load, Snative_elisp_load, 1, 2, 0, struct Lisp_Native_Comp_Unit *comp_u = allocate_native_comp_unit (); if (!NILP (Fgethash (filename, all_loaded_comp_units_h, Qnil)) + && !file_in_eln_sys_dir (filename) && !NILP (Ffile_writable_p (filename))) { /* If in this session there was ever a file loaded with this commit a26b14733bba6659548f00db634bc45ccd222447 Merge: 107514a6e2 931b9f5953 Author: Andrea Corallo Date: Thu Sep 10 10:45:02 2020 +0200 Merge remote-tracking branch 'savannah/master' into HEAD commit 107514a6e21f2c434cdae0eca76fe0a60e287ac8 Author: Andrea Corallo Date: Thu Sep 10 07:35:29 2020 +0200 * Fix rename file error when reloading the same file from an sys eln dir. * src/comp.c (Fnative_elisp_load): Don't rename files we don't have the permission for. diff --git a/src/comp.c b/src/comp.c index 5880224ac7..4550833a6a 100644 --- a/src/comp.c +++ b/src/comp.c @@ -4924,17 +4924,24 @@ DEFUN ("native-elisp-load", Fnative_elisp_load, Snative_elisp_load, 1, 2, 0, xsignal2 (Qnative_lisp_load_failed, build_string ("file does not exists"), filename); struct Lisp_Native_Comp_Unit *comp_u = allocate_native_comp_unit (); - if (!NILP (Fgethash (filename, all_loaded_comp_units_h, Qnil))) + + if (!NILP (Fgethash (filename, all_loaded_comp_units_h, Qnil)) + && !NILP (Ffile_writable_p (filename))) { /* If in this session there was ever a file loaded with this name rename before loading it to make sure we always get a new handle! */ Lisp_Object tmp_filename = - Fmake_temp_file_internal (filename, make_fixnum (0), - build_string (".eln"), Qnil); - Frename_file (filename, tmp_filename, Qnil); - comp_u->handle = dynlib_open (SSDATA (tmp_filename)); - Frename_file (tmp_filename, filename, Qnil); + Fmake_temp_file_internal (filename, Qnil, build_string (".eln.tmp"), + Qnil); + if (NILP (Ffile_writable_p (tmp_filename))) + comp_u->handle = dynlib_open (SSDATA (filename)); + else + { + Frename_file (filename, tmp_filename, Qt); + comp_u->handle = dynlib_open (SSDATA (tmp_filename)); + Frename_file (tmp_filename, filename, Qnil); + } } else comp_u->handle = dynlib_open (SSDATA (filename)); commit c2724c3ebb7228ecd8607c3017334e0efb57e069 Author: Andrea Corallo Date: Thu Sep 10 07:37:33 2020 +0200 Revert "* src/comp.c (Fcomp__compile_ctxt_to_file): Don't cleanup caches at bootstrap." This reverts commit 15acd27d1c0de8b56bab61daa0a8fcd4fef0fdc4. diff --git a/src/comp.c b/src/comp.c index 71a36a60a0..5880224ac7 100644 --- a/src/comp.c +++ b/src/comp.c @@ -4359,10 +4359,7 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, GCC_JIT_OUTPUT_KIND_DYNAMIC_LIBRARY, SSDATA (tmp_file)); - /* FIXME: this if workaround a cc-bytecomp compilation issue - appearing on the Docker build that must be investigated. */ - if (NILP (Fsymbol_value(intern_c_string ("byte-native-for-bootstrap")))) - CALL1I (comp-clean-up-stale-eln, file_name); + CALL1I (comp-clean-up-stale-eln, file_name); CALL2I (comp-delete-or-replace-file, file_name, tmp_file); if (!noninteractive) commit 15acd27d1c0de8b56bab61daa0a8fcd4fef0fdc4 Author: Andrea Corallo Date: Tue Sep 8 10:58:59 2020 +0200 * src/comp.c (Fcomp__compile_ctxt_to_file): Don't cleanup caches at bootstrap. diff --git a/src/comp.c b/src/comp.c index 5880224ac7..71a36a60a0 100644 --- a/src/comp.c +++ b/src/comp.c @@ -4359,7 +4359,10 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, GCC_JIT_OUTPUT_KIND_DYNAMIC_LIBRARY, SSDATA (tmp_file)); - CALL1I (comp-clean-up-stale-eln, file_name); + /* FIXME: this if workaround a cc-bytecomp compilation issue + appearing on the Docker build that must be investigated. */ + if (NILP (Fsymbol_value(intern_c_string ("byte-native-for-bootstrap")))) + CALL1I (comp-clean-up-stale-eln, file_name); CALL2I (comp-delete-or-replace-file, file_name, tmp_file); if (!noninteractive) commit ff89ec0d366f6fa8cf25702f8b3bc3d4cd0833b4 Author: Andrea Corallo Date: Mon Sep 7 23:57:52 2020 +0200 * Name temp eln files as .eln.tmp so we can't clean-up them mistakenly. * src/comp.c (Fcomp__compile_ctxt_to_file): Postfix temporary eln files as .eln.tmp. diff --git a/src/comp.c b/src/comp.c index 70bb560da6..5880224ac7 100644 --- a/src/comp.c +++ b/src/comp.c @@ -4353,10 +4353,8 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, if (COMP_DEBUG > 2) gcc_jit_context_dump_reproducer_to_file (comp.ctxt, "comp_reproducer.c"); - AUTO_STRING (dot_eln, NATIVE_ELISP_SUFFIX); - Lisp_Object tmp_file = - Fmake_temp_file_internal (base_name, Qnil, dot_eln, Qnil); + Fmake_temp_file_internal (base_name, Qnil, build_string (".eln.tmp"), Qnil); gcc_jit_context_compile_to_file (comp.ctxt, GCC_JIT_OUTPUT_KIND_DYNAMIC_LIBRARY, SSDATA (tmp_file)); commit dc4b50ce0b52d8fcade1e04aabd92409858fcfc2 Author: Andrea Corallo Date: Mon Sep 7 23:13:28 2020 +0200 * Do not crash compilation if user eln-cache wasn't already created. * lisp/emacs-lisp/comp.el (comp-clean-up-stale-eln): Guard against calling `directory-files' on non existent directories. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 129a4dedaf..cfc5ca5548 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2516,8 +2516,9 @@ sharing the original source filename (including FILE)." `(seq "-" ,filename-hash "-" (1+ hex) ".eln" eos)) for dir in (butlast comp-eln-load-path) ; Skip last dir. do (cl-loop - for f in (directory-files (concat dir comp-native-version-dir) t regexp - t) + with full-dir = (concat dir comp-native-version-dir) + for f in (when (file-exists-p full-dir) + (directory-files full-dir t regexp t)) do (comp-delete-or-replace-file f)))) (defun comp-delete-or-replace-file (oldfile &optional newfile) commit d344e79be9fb82a38a89c892e24d5ca71fbff810 Author: Andrea Corallo Date: Sun Sep 6 18:21:00 2020 +0200 * src/data.c (subr-native-lambda-list): Defined it unconditionally (bug#43255) diff --git a/src/data.c b/src/data.c index 0acae67b2a..85c73b406c 100644 --- a/src/data.c +++ b/src/data.c @@ -882,8 +882,6 @@ function, nil otherwise. */) return SUBR_NATIVE_COMPILEDP (object) ? Qt : Qnil; } -#ifdef HAVE_NATIVE_COMP - DEFUN ("subr-native-lambda-list", Fsubr_native_lambda_list, Ssubr_native_lambda_list, 1, 1, 0, doc: /* Return the lambda list for a native compiled lisp/d @@ -897,6 +895,8 @@ function or t otherwise. */) : Qt; } +#ifdef HAVE_NATIVE_COMP + DEFUN ("subr-native-comp-unit", Fsubr_native_comp_unit, Ssubr_native_comp_unit, 1, 1, 0, doc: /* Return the native compilation unit. */) commit 3a9139d197ea1a211b64ca70e1f7e1f0545a4424 Author: Andrea Corallo Date: Sun Sep 6 18:20:00 2020 +0200 * src/comp.c (Fcomp__compile_ctxt_to_file): Rename a variable. diff --git a/src/comp.c b/src/comp.c index ddecacd74e..70bb560da6 100644 --- a/src/comp.c +++ b/src/comp.c @@ -4353,10 +4353,10 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, if (COMP_DEBUG > 2) gcc_jit_context_dump_reproducer_to_file (comp.ctxt, "comp_reproducer.c"); - AUTO_STRING (dot_so, NATIVE_ELISP_SUFFIX); + AUTO_STRING (dot_eln, NATIVE_ELISP_SUFFIX); Lisp_Object tmp_file = - Fmake_temp_file_internal (base_name, Qnil, dot_so, Qnil); + Fmake_temp_file_internal (base_name, Qnil, dot_eln, Qnil); gcc_jit_context_compile_to_file (comp.ctxt, GCC_JIT_OUTPUT_KIND_DYNAMIC_LIBRARY, SSDATA (tmp_file)); commit 3df471e1f4723cc0d860b31f5153ee8e47503e34 Author: Andrea Corallo Date: Sun Sep 6 18:19:00 2020 +0200 * src/comp.c (Fnative_elisp_load): Make recompilation always effective. When loading a file if in this session there was ever a file loaded with that name rename it before loading it to make sure we always get a new handle from the standard library. diff --git a/src/comp.c b/src/comp.c index 68a0ead69a..ddecacd74e 100644 --- a/src/comp.c +++ b/src/comp.c @@ -4916,20 +4916,35 @@ DEFUN ("comp--late-register-subr", Fcomp__late_register_subr, /* Load related routines. */ DEFUN ("native-elisp-load", Fnative_elisp_load, Snative_elisp_load, 1, 2, 0, - doc: /* Load native elisp code FILE. + doc: /* Load native elisp code FILENAME. LATE_LOAD has to be non nil when loading for deferred compilation. */) - (Lisp_Object file, Lisp_Object late_load) + (Lisp_Object filename, Lisp_Object late_load) { - CHECK_STRING (file); - if (NILP (Ffile_exists_p (file))) + CHECK_STRING (filename); + if (NILP (Ffile_exists_p (filename))) xsignal2 (Qnative_lisp_load_failed, build_string ("file does not exists"), - file); + filename); struct Lisp_Native_Comp_Unit *comp_u = allocate_native_comp_unit (); - comp_u->handle = dynlib_open (SSDATA (file)); + if (!NILP (Fgethash (filename, all_loaded_comp_units_h, Qnil))) + { + /* If in this session there was ever a file loaded with this + name rename before loading it to make sure we always get a + new handle! */ + Lisp_Object tmp_filename = + Fmake_temp_file_internal (filename, make_fixnum (0), + build_string (".eln"), Qnil); + Frename_file (filename, tmp_filename, Qnil); + comp_u->handle = dynlib_open (SSDATA (tmp_filename)); + Frename_file (tmp_filename, filename, Qnil); + } + else + comp_u->handle = dynlib_open (SSDATA (filename)); + if (!comp_u->handle) - xsignal2 (Qnative_lisp_load_failed, file, build_string (dynlib_error ())); - comp_u->file = file; + xsignal2 (Qnative_lisp_load_failed, filename, + build_string (dynlib_error ())); + comp_u->file = filename; comp_u->data_vec = Qnil; comp_u->lambda_gc_guard_h = CALLN (Fmake_hash_table, QCtest, Qeq); comp_u->lambda_c_name_idx_h = CALLN (Fmake_hash_table, QCtest, Qequal); commit a71f54eff80cb7d7b36326849eea878073963594 Author: Andrea Corallo Date: Sun Sep 6 18:17:00 2020 +0200 Rework eln deletion strategy for new eln-cache folder structure When recompiling remove the corresponding stale elns found in the `comp-eln-load-path'. When removing a package remove the corresponding elns too. On Windows both of these are performed only when possible, when it's not the file is renamed as .eln.old and a last attempt to remove this is performed closing the Emacs session. When a file being deleted was loaded by multiple Emacs sessions the last one being closed should delete it. * lisp/emacs-lisp/comp.el (comp-clean-up-stale-eln): New function. (comp-delete-or-replace-file): Rename from `comp--replace-output-file' and update so it can be used for replacing or deleting shared libs safetly. * lisp/emacs-lisp/package.el (package--delete-directory): When native compiled just call `comp-clean-up-stale-eln' for each eln file we want to clean-up. * src/alloc.c (cleanup_vector): Call directly the dynlib_close. * src/comp.c (syms_of_comp): Update for comp_u->cfile removal. Make 'all_loaded_comp_units_h' key-value weak as now the key will be the filename. (load_comp_unit): Register the compilation unit only when the load is fully completed. (register_native_comp_unit): Make the key of all_loaded_comp_units_h the load filename. (eln_load_path_final_clean_up): New function. (dispose_comp_unit) (finish_delayed_disposal_of_comp_units) (dispose_all_remaining_comp_units) (clean_package_user_dir_of_old_comp_units): Remove. (Fcomp__compile_ctxt_to_file): Update for `comp--replace-output-file' -> `comp-delete-or-replace-file' rename. * src/comp.h (dispose_comp_unit) (finish_delayed_disposal_of_comp_units) (dispose_all_remaining_comp_units) (clean_package_user_dir_of_old_comp_units): Remove. (eln_load_path_final_clean_up): Add. (struct Lisp_Native_Comp_Unit): Remove cfile field. * src/emacs.c (Fkill_emacs): Call 'eln_load_path_final_clean_up'. * src/pdumper.c (dump_do_dump_relocation): Do not set comp_u->cfile. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 84b5a8bc87..129a4dedaf 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2505,31 +2505,52 @@ Prepare every function for final compilation and drive the C back-end." ;; Some entry point support code. -(defun comp--replace-output-file (outfile tmpfile) - "Replace OUTFILE with TMPFILE. -Takes the necessary steps when dealing with shared libraries that -may be loaded into Emacs" +;;;###autoload +(defun comp-clean-up-stale-eln (file) + "Given FILE remove all the .eln files in `comp-eln-load-path' +sharing the original source filename (including FILE)." + (string-match (rx "-" (group-n 1 (1+ hex)) "-" (1+ hex) ".eln" eos) file) + (cl-loop + with filename-hash = (match-string 1 file) + with regexp = (rx-to-string + `(seq "-" ,filename-hash "-" (1+ hex) ".eln" eos)) + for dir in (butlast comp-eln-load-path) ; Skip last dir. + do (cl-loop + for f in (directory-files (concat dir comp-native-version-dir) t regexp + t) + do (comp-delete-or-replace-file f)))) + +(defun comp-delete-or-replace-file (oldfile &optional newfile) + "Replace OLDFILE with NEWFILE. +When NEWFILE is nil just delete OLDFILE. +Takes the necessary steps when dealing with OLDFILE being a +shared libraries that may be currently loaded by a running Emacs +session." (cond ((eq 'windows-nt system-type) - (ignore-errors (delete-file outfile)) - (let ((retry t)) - (while retry - (setf retry nil) + (ignore-errors (delete-file oldfile)) + (while (condition-case _ (progn - ;; outfile maybe recreated by another Emacs in + ;; oldfile maybe recreated by another Emacs in ;; between the following two rename-file calls - (if (file-exists-p outfile) - (rename-file outfile (make-temp-file-internal - (file-name-sans-extension outfile) + (if (file-exists-p oldfile) + (rename-file oldfile (make-temp-file-internal + (file-name-sans-extension oldfile) nil ".eln.old" nil) t)) - (rename-file tmpfile outfile nil)) - (file-already-exists (setf retry t)))))) + (when newfile + (rename-file newfile oldfile nil)) + ;; Keep on trying. + nil) + (file-already-exists + ;; Done + t)))) ;; Remove the old eln instead of copying the new one into it ;; to get a new inode and prevent crashes in case the old one ;; is currently loaded. - (t (delete-file outfile) - (rename-file tmpfile outfile)))) + (t (delete-file oldfile) + (when newfile + (rename-file newfile oldfile))))) (defvar comp-files-queue () "List of Elisp files to be compiled.") diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index c349b5d49f..c20659a1ae 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -2206,32 +2206,13 @@ If some packages are not installed propose to install them." (defun package--delete-directory (dir) "Delete DIR recursively. -In Windows move .eln and .eln.old files that can not be deleted -to `package-user-dir'." - (cond ((eq 'windows-nt system-type) - (let ((retry t)) - (while retry - (setf retry nil) - (condition-case err - (delete-directory dir t) - (file-error - (cl-destructuring-bind (_ reason1 reason2 filename) err - (if (and (string= "Removing old name" reason1) - (string= "Permission denied" reason2) - (string-prefix-p (expand-file-name package-user-dir) - filename) - (or (string-suffix-p ".eln" filename) - (string-suffix-p ".eln.old" filename))) - (progn - (rename-file filename - (make-temp-file-internal - (concat package-user-dir - (file-name-base filename)) - nil ".eln.old" nil) - t) - (setf retry t)) - (signal (car err) (cdr err))))))))) - (t (delete-directory dir t)))) +Clean-up the corresponding .eln files if Emacs is native +compiled." + (when (boundp 'comp-ctxt) + (cl-loop + for file in (directory-files-recursively dir ".el\\'") + do (comp-clean-up-stale-eln (comp-el-to-eln-filename file)))) + (delete-directory dir t)) (defun package-delete (pkg-desc &optional force nosave) "Delete package PKG-DESC. diff --git a/src/alloc.c b/src/alloc.c index 6701bf002b..bde0a16ac1 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -3153,7 +3153,8 @@ cleanup_vector (struct Lisp_Vector *vector) { struct Lisp_Native_Comp_Unit *cu = PSEUDOVEC_STRUCT (vector, Lisp_Native_Comp_Unit); - dispose_comp_unit (cu, true); + eassert (cu->handle); + dynlib_close (cu->handle); } else if (NATIVE_COMP_FLAG && PSEUDOVECTOR_TYPEP (&vector->header, PVEC_SUBR)) diff --git a/src/comp.c b/src/comp.c index 3a56f5f22c..68a0ead69a 100644 --- a/src/comp.c +++ b/src/comp.c @@ -4361,7 +4361,8 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, GCC_JIT_OUTPUT_KIND_DYNAMIC_LIBRARY, SSDATA (tmp_file)); - CALL2I (comp--replace-output-file, file_name, tmp_file); + CALL1I (comp-clean-up-stale-eln, file_name); + CALL2I (comp-delete-or-replace-file, file_name, tmp_file); if (!noninteractive) unbind_to (count, Qnil); @@ -4438,220 +4439,44 @@ helper_PSEUDOVECTOR_TYPEP_XUNTAG (Lisp_Object a, enum pvec_type code) } -/*********************************/ -/* Disposal of compilation units */ -/*********************************/ - -/* - The problem: Windows does not let us delete an .eln file that has - been loaded by a process. This has two implications in Emacs: - - 1) It is not possible to recompile a lisp file if the corresponding - .eln file has been loaded. This is because we'd like to use the same - filename, but we can't delete the old .eln file. - - 2) It is not possible to delete a package using `package-delete' - if an .eln file has been loaded. - - * General idea - - The solution to these two problems is to move the foo.eln file - somewhere else and have the last Emacs instance using it delete it. - To make it easy to find what files need to be removed we use two approaches. - - In the 1) case we rename foo.eln to fooXXXXXX.eln.old in the same - folder. When Emacs is unloading "foo" (either GC'd the native - compilation unit or Emacs is closing (see below)) we delete all the - .eln.old files in the folder where the original foo.eln was stored. - - Ideally we'd figure out the new name of foo.eln and delete it if it - ends in .eln.old. There is no simple API to do this in Windows. - GetModuleFileName () returns the original filename, not the current - one. This forces us to put .eln.old files in an agreed upon path. - We cannot use %TEMP% because it may be in another drive and then the - rename operation would fail. - - In the 2) case we can't use the same folder where the .eln file - resided, as we are trying to completely remove the package. Since we - are removing packages we can safely move the .eln.old file to - `package-user-dir' as we are sure that that would not mean changing - drives. - - * Implementation details - - The concept of disposal of a native compilation unit refers to - unloading the shared library and deleting all the .eln.old files in - the directory. These are two separate steps. We'll call them - early-disposal and late-disposal. - - There are two data structures used: - - - The `all_loaded_comp_units_h` hashtable. - - This hashtable is used like an array of weak references to native - compilation units. This hash table is filled by load_comp_unit () - and dispose_all_remaining_comp_units () iterates over all values - that were not disposed by the GC and performs all disposal steps - when Emacs is closing. - - - The `delayed_comp_unit_disposal_list` list. - - This is were the dispose_comp_unit () function, when called by the - GC sweep stage, stores the original filenames of the disposed native - compilation units. This is an ad-hoc C structure instead of a Lisp - cons because we need to allocate instances of this structure during - the GC. - - The finish_delayed_disposal_of_comp_units () function will iterate - over this list and perform the late-disposal step when Emacs is - closing. - -*/ - -#ifdef WINDOWSNT -#define OLD_ELN_SUFFIX_REGEXP build_string ("\\.eln\\.old\\'") +/* `comp-eln-load-path' clean-up support code. */ static Lisp_Object all_loaded_comp_units_h; -/* We need to allocate instances of this struct during a GC sweep. - This is why it can't be transformed into a simple cons. */ -struct delayed_comp_unit_disposal -{ - struct delayed_comp_unit_disposal *next; - char *filename; -}; - -struct delayed_comp_unit_disposal *delayed_comp_unit_disposal_list; - -static Lisp_Object -return_nil (Lisp_Object arg) -{ - return Qnil; -} - -/* Tries to remove all *.eln.old files in DIRNAME. +/* Windows does not let us delete a .eln file that is currently loaded + by a process. The strategy is to rename .eln files into .old.eln + instead of removing them when this is not possible and clean-up + `comp-eln-load-path' when exiting. Any error is ignored because it may be due to the file being loaded in another Emacs instance. */ -static void -clean_comp_unit_directory (Lisp_Object dirpath) -{ - if (NILP (dirpath)) - return; - Lisp_Object files_in_dir; - files_in_dir = internal_condition_case_4 (Fdirectory_files, dirpath, Qt, - OLD_ELN_SUFFIX_REGEXP, Qnil, Qt, - return_nil); - FOR_EACH_TAIL (files_in_dir) { DeleteFile (SSDATA (XCAR (files_in_dir))); } -} - -/* Tries to remove all *.eln.old files in `package-user-dir'. - - This is called when Emacs is closing to clean any *.eln left from a - deleted package. */ void -clean_package_user_dir_of_old_comp_units (void) +eln_load_path_final_clean_up (void) { - Lisp_Object package_user_dir - = find_symbol_value (intern ("package-user-dir")); - if (EQ (package_user_dir, Qunbound) || !STRINGP (package_user_dir)) - return; - - clean_comp_unit_directory (package_user_dir); -} - -/* This function disposes all compilation units that are still loaded. - - It is important that this function is called only right before - Emacs is closed, otherwise we risk running a subr that is - implemented in an unloaded dynamic library. */ -void -dispose_all_remaining_comp_units (void) -{ - struct Lisp_Hash_Table *h = XHASH_TABLE (all_loaded_comp_units_h); - - for (ptrdiff_t i = 0; i < HASH_TABLE_SIZE (h); ++i) - { - Lisp_Object k = HASH_KEY (h, i); - if (!EQ (k, Qunbound)) - { - Lisp_Object val = HASH_VALUE (h, i); - struct Lisp_Native_Comp_Unit *cu = XNATIVE_COMP_UNIT (val); - dispose_comp_unit (cu, false); - } - } -} - -/* This function finishes the disposal of compilation units that were - passed to `dispose_comp_unit` with DELAY == true. +#ifdef WINDOWSNT + Lisp_Object return_nil (Lisp_Object arg) { return Qnil; } - This function is called when Emacs is idle and when it is about to - close. */ -void -finish_delayed_disposal_of_comp_units (void) -{ - for (struct delayed_comp_unit_disposal *item - = delayed_comp_unit_disposal_list; - delayed_comp_unit_disposal_list; item = delayed_comp_unit_disposal_list) + Lisp_Object dir_tail = Vcomp_eln_load_path; + FOR_EACH_TAIL (dir_tail) { - delayed_comp_unit_disposal_list = item->next; - Lisp_Object dirname = internal_condition_case_1 ( - Ffile_name_directory, build_string (item->filename), Qt, return_nil); - clean_comp_unit_directory (dirname); - xfree (item->filename); - xfree (item); + Lisp_Object files_in_dir = + internal_condition_case_4 (Fdirectory_files, + concat2 (XCAR (dir_tail), + Vcomp_native_version_dir), + Qt, build_string ("\\.eln\\.old\\'"), Qnil, + Qt, return_nil); + FOR_EACH_TAIL (files_in_dir) + Fdelete_file (XCAR (files_in_dir), Qnil); } -} #endif +} /* This function puts the compilation unit in the `all_loaded_comp_units_h` hashmap. */ static void register_native_comp_unit (Lisp_Object comp_u) { -#ifdef WINDOWSNT - /* We have to do this since we can't use `gensym'. This function is - called early when loading a dump file and subr.el may not have - been loaded yet. */ - static intmax_t count; - - Fputhash (make_int (count++), comp_u, all_loaded_comp_units_h); -#endif -} - -/* This function disposes compilation units. It is called during the GC sweep - stage and when Emacs is closing. - - On Windows the the DELAY parameter specifies whether the native - compilation file will be deleted right away (if necessary) or put - on a list. That list will be dealt with by - `finish_delayed_disposal_of_comp_units`. */ -void -dispose_comp_unit (struct Lisp_Native_Comp_Unit *comp_handle, bool delay) -{ - eassert (comp_handle->handle); - dynlib_close (comp_handle->handle); -#ifdef WINDOWSNT - if (!delay) - { - Lisp_Object dirname = internal_condition_case_1 ( - Ffile_name_directory, build_string (comp_handle->cfile), Qt, - return_nil); - if (!NILP (dirname)) - clean_comp_unit_directory (dirname); - xfree (comp_handle->cfile); - comp_handle->cfile = NULL; - } - else - { - struct delayed_comp_unit_disposal *head; - head = xmalloc (sizeof (struct delayed_comp_unit_disposal)); - head->next = delayed_comp_unit_disposal_list; - head->filename = comp_handle->cfile; - comp_handle->cfile = NULL; - delayed_comp_unit_disposal_list = head; - } -#endif + Fputhash (XNATIVE_COMP_UNIT (comp_u)->file, comp_u, all_loaded_comp_units_h); } @@ -4663,7 +4488,6 @@ dispose_comp_unit (struct Lisp_Native_Comp_Unit *comp_handle, bool delay) loaded the compiler and its dependencies. */ static Lisp_Object delayed_sources; - /* Queue an asyncronous compilation for the source file defining FUNCTION_NAME and perform a late load. @@ -4922,12 +4746,6 @@ load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u, bool loading_dump, d_vec_len = XFIXNUM (Flength (comp_u->data_impure_vec)); for (EMACS_INT i = 0; i < d_vec_len; i++) data_imp_relocs[i] = AREF (comp_u->data_impure_vec, i); - - /* If we register them while dumping we will get some entries in - the hash table that will be duplicated when pdumper calls - load_comp_unit. */ - if (!will_dump_p ()) - register_native_comp_unit (comp_u_lisp_obj); } if (!loading_dump) @@ -4968,6 +4786,8 @@ load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u, bool loading_dump, /* Clean-up the load ongoing flag in case. */ unbind_to (count, Qnil); + register_native_comp_unit (comp_u_lisp_obj); + return; } @@ -5110,9 +4930,6 @@ DEFUN ("native-elisp-load", Fnative_elisp_load, Snative_elisp_load, 1, 2, 0, if (!comp_u->handle) xsignal2 (Qnative_lisp_load_failed, file, build_string (dynlib_error ())); comp_u->file = file; -#ifdef WINDOWSNT - comp_u->cfile = xlispstrdup (file); -#endif comp_u->data_vec = Qnil; comp_u->lambda_gc_guard_h = CALLN (Fmake_hash_table, QCtest, Qeq); comp_u->lambda_c_name_idx_h = CALLN (Fmake_hash_table, QCtest, Qequal); @@ -5275,10 +5092,9 @@ native compiled one. */); staticpro (&loadsearch_re_list); loadsearch_re_list = Qnil; -#ifdef WINDOWSNT staticpro (&all_loaded_comp_units_h); - all_loaded_comp_units_h = CALLN (Fmake_hash_table, QCweakness, Qvalue); -#endif + all_loaded_comp_units_h = + CALLN (Fmake_hash_table, QCweakness, Qkey_and_value, QCtest, Qequal); DEFVAR_LISP ("comp-ctxt", Vcomp_ctxt, doc: /* The compiler context. */); diff --git a/src/comp.h b/src/comp.h index 9270f8bf66..5c7bed6a30 100644 --- a/src/comp.h +++ b/src/comp.h @@ -54,13 +54,6 @@ struct Lisp_Native_Comp_Unit bool loaded_once; bool load_ongoing; dynlib_handle_ptr handle; -#ifdef WINDOWSNT - /* We need to store a copy of the original file name in memory that - is not subject to GC because the function to dispose native - compilation units is called by the GC. By that time the `file' - string may have been sweeped. */ - char *cfile; -#endif } GCALIGNED_STRUCT; #ifdef HAVE_NATIVE_COMP @@ -92,14 +85,7 @@ extern void syms_of_comp (void); extern void maybe_defer_native_compilation (Lisp_Object function_name, Lisp_Object definition); -extern void dispose_comp_unit (struct Lisp_Native_Comp_Unit * comp_unit, - bool delay); - -extern void finish_delayed_disposal_of_comp_units (void); - -extern void dispose_all_remaining_comp_units (void); - -extern void clean_package_user_dir_of_old_comp_units (void); +extern void eln_load_path_final_clean_up (void); extern void fixup_eln_load_path (Lisp_Object directory); @@ -112,24 +98,6 @@ maybe_defer_native_compilation (Lisp_Object function_name, extern void syms_of_comp (void); -static inline void -dispose_comp_unit (struct Lisp_Native_Comp_Unit * comp_handle, bool delay) -{ - eassert (false); -} - -static inline void -dispose_all_remaining_comp_units (void) -{} - -static inline void -clean_package_user_dir_of_old_comp_units (void) -{} - -static inline void -finish_delayed_disposal_of_comp_units (void) -{} - #endif /* #ifdef HAVE_NATIVE_COMP */ #endif /* #ifndef COMP_H */ diff --git a/src/emacs.c b/src/emacs.c index 8e52da7592..07e40fdc8b 100644 --- a/src/emacs.c +++ b/src/emacs.c @@ -2407,10 +2407,8 @@ all of which are called before Emacs is actually killed. */ unlink (SSDATA (listfile)); } -#if defined (HAVE_NATIVE_COMP) && defined (WINDOWSNT) - finish_delayed_disposal_of_comp_units (); - dispose_all_remaining_comp_units (); - clean_package_user_dir_of_old_comp_units (); +#ifdef HAVE_NATIVE_COMP + eln_load_path_final_clean_up (); #endif if (FIXNUMP (arg)) diff --git a/src/pdumper.c b/src/pdumper.c index 9c615a9a1a..da5e7a1736 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -5275,9 +5275,6 @@ dump_do_dump_relocation (const uintptr_t dump_base, concat2 (Vinvocation_directory, installation_state == INSTALLED ? XCAR (comp_u->file) : XCDR (comp_u->file)); -#ifdef WINDOWSNT - comp_u->cfile = xlispstrdup (comp_u->file); -#endif comp_u->handle = dynlib_open (SSDATA (comp_u->file)); if (!comp_u->handle) error ("%s", dynlib_error ()); commit eb8742598874d9bd4c84ff54730527c52d29d7ff Author: Andrea Corallo Date: Sun Sep 6 08:08:19 2020 +0200 * Makefile.in (ELN_DESTDIR): Add ${version}/ to it. diff --git a/Makefile.in b/Makefile.in index d42ad9dfa1..2b47762b7b 100644 --- a/Makefile.in +++ b/Makefile.in @@ -332,7 +332,7 @@ CONFIG_STATUS_FILES_IN = \ COPYDIR = ${srcdir}/etc ${srcdir}/lisp COPYDESTS = "$(DESTDIR)${etcdir}" "$(DESTDIR)${lispdir}" -ELN_DESTDIR = "$(DESTDIR)${libdir}/emacs/" +ELN_DESTDIR = "$(DESTDIR)${libdir}/emacs/${version}/" all: ${SUBDIR} info commit 805563346613af1f13ecd1bf96ffd8efe4816b47 Merge: 67c5369156 669b46e6a3 Author: Andrea Corallo Date: Sun Sep 6 08:07:30 2020 +0200 Merge remote-tracking branch 'savannah/master' into HEAD commit 67c53691560616598f746491347bd223480e6172 Author: Andrea Corallo Date: Fri Sep 4 11:54:44 2020 +0200 Rename and move eln system directory Rename eln sys directory into 'native-lisp' and move it from "$(DESTDIR)${libexecdir}/emacs/${version}/${configuration}/" to "$(DESTDIR)${libdir}/emacs/". Add to the directory name used to disambiguate the eln compatibility the Emacs version to have it more user friendly. * Makefile.in (clean, install-eln): Rename eln-cache into native-lisp. (ELN_DESTDIR): Move from '$(DESTDIR)${libexecdir}/emacs/${version}/${configuration}/' to '$(DESTDIR)${libdir}/emacs/'. * lisp/loadup.el: Update for comp-native-path-postfix -> comp-native-version-dir rename. * src/comp.c (syms_of_comp): Rename eln-cache -> native-lisp. (syms_of_comp, Fcomp_el_to_eln_filename): Rename comp-native-path-postfix -> comp-native-version-dir. (hash_native_abi): Rework and add emacs-version to comp-native-version-dir. diff --git a/Makefile.in b/Makefile.in index a15850d55e..d42ad9dfa1 100644 --- a/Makefile.in +++ b/Makefile.in @@ -332,7 +332,7 @@ CONFIG_STATUS_FILES_IN = \ COPYDIR = ${srcdir}/etc ${srcdir}/lisp COPYDESTS = "$(DESTDIR)${etcdir}" "$(DESTDIR)${lispdir}" -ELN_DESTDIR = "$(DESTDIR)${libexecdir}/emacs/${version}/${configuration}/" +ELN_DESTDIR = "$(DESTDIR)${libdir}/emacs/" all: ${SUBDIR} info @@ -760,7 +760,7 @@ install-etc: ### Install native compiled Lisp files. install-eln: ifeq ($(HAVE_NATIVE_COMP),yes) - find eln-cache -type f -exec ${INSTALL_DATA} -D "{}" "$(ELN_DESTDIR){}" \; + find native-lisp -type f -exec ${INSTALL_DATA} -D "{}" "$(ELN_DESTDIR){}" \; endif ### Build Emacs and install it, stripping binaries while installing them. @@ -873,7 +873,7 @@ clean: $(clean_dirs:=_clean) [ ! -d test ] || $(MAKE) -C test $@ -rm -f ./*.tmp etc/*.tmp* -rm -rf info-dir.* - -rm -rf eln-cache + -rm -rf native-lisp ### 'bootclean' ### Delete all files that need to be remade for a clean bootstrap. diff --git a/lisp/loadup.el b/lisp/loadup.el index aaa5888bf9..5718477ea0 100644 --- a/lisp/loadup.el +++ b/lisp/loadup.el @@ -458,7 +458,7 @@ lost after dumping"))) (eln-dest-dir (cadr (member "--eln-dest" command-line-args)))) (when (and bin-dest-dir eln-dest-dir) (setq eln-dest-dir - (concat eln-dest-dir "eln-cache/" comp-native-path-postfix "/")) + (concat eln-dest-dir "native-lisp/" comp-native-version-dir "/")) (mapatoms (lambda (s) (let ((f (symbol-function s))) (when (subr-native-elisp-p f) diff --git a/src/comp.c b/src/comp.c index fa5ffadf31..3a56f5f22c 100644 --- a/src/comp.c +++ b/src/comp.c @@ -771,21 +771,19 @@ comp_hash_source_file (Lisp_Object filename) void hash_native_abi (void) { - Lisp_Object string = Fmapconcat (intern_c_string ("subr-name"), - Vcomp_subr_list, build_string (" ")); - Lisp_Object digest = comp_hash_string (string); - /* Check runs once. */ eassert (NILP (Vcomp_abi_hash)); - Vcomp_abi_hash = digest; - /* If 10 characters are usually sufficient for git I guess 16 are - fine for us here. */ - Vcomp_native_path_postfix = - concat2 (Vsystem_configuration, - concat2 (make_string ("-", 1), - Fsubstring_no_properties (Vcomp_abi_hash, - make_fixnum (0), - make_fixnum (16)))); + + Vcomp_abi_hash = + comp_hash_string (Fmapconcat (intern_c_string ("subr-name"), + Vcomp_subr_list, build_string (""))); + Lisp_Object separator = build_string ("-"); + Vcomp_native_version_dir = + concat3 (Vemacs_version, + separator, + concat3 (Vsystem_configuration, + separator, + Vcomp_abi_hash)); } static void @@ -4057,7 +4055,7 @@ If BASE-DIR is nil use the first entry in `comp-eln-load-path'. */) base_dir = Fexpand_file_name (base_dir, Vinvocation_directory); return Fexpand_file_name (filename, - concat2 (base_dir, Vcomp_native_path_postfix)); + concat2 (base_dir, Vcomp_native_version_dir)); } DEFUN ("comp--init-ctxt", Fcomp__init_ctxt, Scomp__init_ctxt, @@ -5293,9 +5291,9 @@ native compiled one. */); DEFVAR_LISP ("comp-abi-hash", Vcomp_abi_hash, doc: /* String signing the ABI exposed to .eln files. */); Vcomp_abi_hash = Qnil; - DEFVAR_LISP ("comp-native-path-postfix", Vcomp_native_path_postfix, - doc: /* Postifix to be added to the .eln compilation path. */); - Vcomp_native_path_postfix = Qnil; + DEFVAR_LISP ("comp-native-version-dir", Vcomp_native_version_dir, + doc: /* Directory in use to disambiguate eln compatibility. */); + Vcomp_native_version_dir = Qnil; DEFVAR_LISP ("comp-deferred-pending-h", Vcomp_deferred_pending_h, doc: /* Hash table symbol-name -> function-value. For @@ -5316,7 +5314,7 @@ The last directory of this list is assumed to be the system one. */); /* Temporary value in use for boostrap. We can't do better as `invocation-directory' is still unset, will be fixed up during dump reload. */ - Vcomp_eln_load_path = Fcons (build_string ("../eln-cache/"), Qnil); + Vcomp_eln_load_path = Fcons (build_string ("../native-lisp/"), Qnil); #endif /* #ifdef HAVE_NATIVE_COMP */ commit 3023eb569213a3dd5183640f6e322acd00ea536a Author: Andrea Corallo Date: Tue Sep 1 20:04:00 2020 +0200 * Fix `load-filename' for installed instance (bug#43089) * src/lread.c (parent_directory): Remove function as now unnecessary. (compute_found_effective): New function. (Fload): Make use of 'compute_found_effective' and fix `load-filename' computation. diff --git a/src/lread.c b/src/lread.c index 80d36f571c..3c226e0b50 100644 --- a/src/lread.c +++ b/src/lread.c @@ -1099,12 +1099,22 @@ close_infile_unwind (void *arg) infile = prev_infile; } -static ATTRIBUTE_UNUSED Lisp_Object -parent_directory (Lisp_Object directory) +/* Compute the filename we want in `load-history' and `load-file-name'. */ + +static Lisp_Object +compute_found_effective (Lisp_Object found) { - return Ffile_name_directory (Fsubstring (directory, - make_fixnum (0), - Fsub1 (Flength (directory)))); + /* Reconstruct the .elc filename. */ + Lisp_Object src_name = + Fgethash (Ffile_name_nondirectory (found), Vcomp_eln_to_el_h, Qnil); + + if (NILP (src_name)) + /* Manual eln load. */ + return found; + + if (suffix_p (src_name, "el.gz")) + src_name = Fsubstring (src_name, make_fixnum (0), make_fixnum (-3)); + return concat2 (src_name, build_string ("c")); } DEFUN ("load", Fload, Sload, 1, 5, 0, @@ -1321,30 +1331,15 @@ Return t if the file exists and loads successfully. */) Vload_source_file_function. */ specbind (Qlexical_binding, Qnil); - /* Get the name for load-history. */ - Lisp_Object found_for_hist; - if (is_native_elisp) - { - /* Reconstruct the .elc filename. */ - Lisp_Object src_name = Fgethash (Ffile_name_nondirectory (found), - Vcomp_eln_to_el_h, Qnil); - if (NILP (src_name)) - /* Manual eln load. */ - found_for_hist = found; - else - { - if (suffix_p (src_name, "el.gz")) - src_name = Fsubstring (src_name, make_fixnum (0), make_fixnum (-3)); - found_for_hist = concat2 (src_name, build_string ("c")); - } - } - else - found_for_hist = found; + Lisp_Object found_eff = + is_native_elisp + ? compute_found_effective (found) + : found; hist_file_name = (! NILP (Vpurify_flag) ? concat2 (Ffile_name_directory (file), - Ffile_name_nondirectory (found_for_hist)) - : found_for_hist); + Ffile_name_nondirectory (found_eff)) + : found_eff); version = -1; @@ -1489,20 +1484,7 @@ Return t if the file exists and loads successfully. */) message_with_string ("Loading %s...", file, 1); } - if (is_native_elisp) - { - /* Many packages use `load-file-name' as a way to obtain the - package location (see bug#40099). .eln files are not in the - same folder of their respective sources therfore not to break - packages we fake `load-file-name' here. The non faked - version of it is `load-true-file-name'. */ - Lisp_Object el_name = Fgethash (Ffile_name_nondirectory (found), - Vcomp_eln_to_el_h, Qnil); - specbind (Qload_file_name, - NILP (el_name) ? Qnil : concat2 (el_name, build_string ("c"))); - } - else - specbind (Qload_file_name, found); + specbind (Qload_file_name, found_eff); specbind (Qload_true_file_name, found); specbind (Qinhibit_file_name_operation, Qnil); specbind (Qload_in_progress, Qt); commit 78e8f991542160239049a50386ced50e456dc5c4 Author: Andrea Corallo Date: Tue Sep 1 10:28:29 2020 +0200 Rework native compiled lisp/d lambda list accessor * lisp/help.el (help-function-arglist): Logic update for new 'Fsubr_native_lambda_list'. * src/data.c (Fsubr_native_dyn_p): Remove. (Fsubr_native_lambda_list): Return t when the input is not a compiled lisp/d subr. (syms_of_data): Update for 'Fsubr_native_dyn_p' removal. diff --git a/lisp/help.el b/lisp/help.el index 01817ab95d..897ab4a425 100644 --- a/lisp/help.el +++ b/lisp/help.el @@ -1337,7 +1337,8 @@ the same names as used in the original source code, when possible." ((and (byte-code-function-p def) (listp (aref def 0))) (aref def 0)) ((eq (car-safe def) 'lambda) (nth 1 def)) ((eq (car-safe def) 'closure) (nth 2 def)) - ((subr-native-dyn-p def) (subr-native-lambda-list def)) + ((and (subrp def) (listp (subr-native-lambda-list def))) + (subr-native-lambda-list def)) ((or (and (byte-code-function-p def) (integerp (aref def 0))) (subrp def) (module-function-p def)) (or (when preserve-names diff --git a/src/data.c b/src/data.c index b7955932b8..0acae67b2a 100644 --- a/src/data.c +++ b/src/data.c @@ -884,26 +884,17 @@ function, nil otherwise. */) #ifdef HAVE_NATIVE_COMP -DEFUN ("subr-native-dyn-p", Fsubr_native_dyn_p, - Ssubr_native_dyn_p, 1, 1, 0, - doc: /* Return t if the subr is native compiled lisp/d -function, nil otherwise. */) - (Lisp_Object subr) -{ - return SUBR_NATIVE_COMPILED_DYNP (subr) ? Qt : Qnil; -} - DEFUN ("subr-native-lambda-list", Fsubr_native_lambda_list, Ssubr_native_lambda_list, 1, 1, 0, - doc: /* Return the lambda list of native compiled lisp/d -function. */) + doc: /* Return the lambda list for a native compiled lisp/d +function or t otherwise. */) (Lisp_Object subr) { CHECK_SUBR (subr); return SUBR_NATIVE_COMPILED_DYNP (subr) ? XSUBR (subr)->lambda_list[0] - : Qnil; + : Qt; } DEFUN ("subr-native-comp-unit", Fsubr_native_comp_unit, @@ -4051,7 +4042,6 @@ syms_of_data (void) defsubr (&Ssubr_name); defsubr (&Ssubr_native_elisp_p); #ifdef HAVE_NATIVE_COMP - defsubr (&Ssubr_native_dyn_p); defsubr (&Ssubr_native_lambda_list); defsubr (&Ssubr_native_comp_unit); defsubr (&Snative_comp_unit_file); commit ba0a61d10a5aedaf4b7bb61aa3626f385d6aba12 Author: Andrea Corallo Date: Mon Aug 31 22:21:22 2020 +0200 * src/lread.c (Fload): Fix for manual eln load. diff --git a/src/lread.c b/src/lread.c index ac5b2838ee..80d36f571c 100644 --- a/src/lread.c +++ b/src/lread.c @@ -1328,9 +1328,15 @@ Return t if the file exists and loads successfully. */) /* Reconstruct the .elc filename. */ Lisp_Object src_name = Fgethash (Ffile_name_nondirectory (found), Vcomp_eln_to_el_h, Qnil); - if (suffix_p (src_name, "el.gz")) - src_name = Fsubstring (src_name, make_fixnum (0), make_fixnum (-3)); - found_for_hist = concat2 (src_name, build_string ("c")); + if (NILP (src_name)) + /* Manual eln load. */ + found_for_hist = found; + else + { + if (suffix_p (src_name, "el.gz")) + src_name = Fsubstring (src_name, make_fixnum (0), make_fixnum (-3)); + found_for_hist = concat2 (src_name, build_string ("c")); + } } else found_for_hist = found; commit c6f42387e32a4e99cd9ddd203ab51f3c5694054e Author: Andrea Corallo Date: Mon Aug 31 22:06:49 2020 +0200 Fix describe function arglist for native compiled lisp/d (bug#42572) * lisp/help.el (help-function-arglist): Handle the case of native compiled lisp/d. * src/data.c (syms_of_data): Register new subrs. (Fsubr_native_dyn_p, Fsubr_native_lambda_list): New primitives. * test/src/comp-tests.el (comp-tests-dynamic-help-arglist): New test. diff --git a/lisp/help.el b/lisp/help.el index 1b0149616f..01817ab95d 100644 --- a/lisp/help.el +++ b/lisp/help.el @@ -1337,6 +1337,7 @@ the same names as used in the original source code, when possible." ((and (byte-code-function-p def) (listp (aref def 0))) (aref def 0)) ((eq (car-safe def) 'lambda) (nth 1 def)) ((eq (car-safe def) 'closure) (nth 2 def)) + ((subr-native-dyn-p def) (subr-native-lambda-list def)) ((or (and (byte-code-function-p def) (integerp (aref def 0))) (subrp def) (module-function-p def)) (or (when preserve-names diff --git a/src/data.c b/src/data.c index 33711368f1..b7955932b8 100644 --- a/src/data.c +++ b/src/data.c @@ -875,14 +875,37 @@ SUBR must be a built-in function. */) } DEFUN ("subr-native-elisp-p", Fsubr_native_elisp_p, Ssubr_native_elisp_p, 1, 1, - 0, doc: /* Return t if the object is native compiled lisp function, -nil otherwise. */) + 0, doc: /* Return t if the object is native compiled lisp +function, nil otherwise. */) (Lisp_Object object) { return SUBR_NATIVE_COMPILEDP (object) ? Qt : Qnil; } #ifdef HAVE_NATIVE_COMP + +DEFUN ("subr-native-dyn-p", Fsubr_native_dyn_p, + Ssubr_native_dyn_p, 1, 1, 0, + doc: /* Return t if the subr is native compiled lisp/d +function, nil otherwise. */) + (Lisp_Object subr) +{ + return SUBR_NATIVE_COMPILED_DYNP (subr) ? Qt : Qnil; +} + +DEFUN ("subr-native-lambda-list", Fsubr_native_lambda_list, + Ssubr_native_lambda_list, 1, 1, 0, + doc: /* Return the lambda list of native compiled lisp/d +function. */) + (Lisp_Object subr) +{ + CHECK_SUBR (subr); + + return SUBR_NATIVE_COMPILED_DYNP (subr) + ? XSUBR (subr)->lambda_list[0] + : Qnil; +} + DEFUN ("subr-native-comp-unit", Fsubr_native_comp_unit, Ssubr_native_comp_unit, 1, 1, 0, doc: /* Return the native compilation unit. */) @@ -4028,6 +4051,8 @@ syms_of_data (void) defsubr (&Ssubr_name); defsubr (&Ssubr_native_elisp_p); #ifdef HAVE_NATIVE_COMP + defsubr (&Ssubr_native_dyn_p); + defsubr (&Ssubr_native_lambda_list); defsubr (&Ssubr_native_comp_unit); defsubr (&Snative_comp_unit_file); defsubr (&Snative_comp_unit_set_file); diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 2a078be8cb..b147bd6789 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -582,6 +582,13 @@ https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-03/msg00914.html." (should (equal '(2 . many) (func-arity #'comp-tests-ffuncall-callee-opt-rest-dyn-f)))) +(ert-deftest comp-tests-dynamic-help-arglist () + "Test `help-function-arglist' works on lisp/d (bug#42572)." + (should (equal (help-function-arglist + (symbol-function #'comp-tests-ffuncall-callee-opt-rest-dyn-f) + t) + '(a b &optional c &rest d)))) + (ert-deftest comp-tests-cl-macro-exp () "Verify CL macro expansion (bug#42088)." (should (equal (comp-tests-cl-macro-exp-f) '(a b)))) commit bce9cad4213f9af8be08311ac2b93add5c93a997 Author: Andrea Corallo Date: Sun Aug 30 10:23:49 2020 +0200 * Store raw documentation during native compilation (bug#42974) * lisp/emacs-lisp/comp.el (comp-spill-lap-function) (comp-intern-func-in-ctxt): Use raw documentation. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 238bdcd5db..84b5a8bc87 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -671,7 +671,7 @@ clashes." (c-name (comp-c-func-name function-name "F")) (func (make-comp-func-l :name function-name :c-name c-name - :doc (documentation f) + :doc (documentation f t) :int-spec (interactive-form f) :speed (comp-spill-speed function-name) :pure (comp-spill-decl-spec function-name @@ -720,7 +720,7 @@ clashes." (make-comp-func-d :lambda-list (aref byte-func 0))))) (setf (comp-func-name func) name (comp-func-byte-func func) byte-func - (comp-func-doc func) (documentation byte-func) + (comp-func-doc func) (documentation byte-func t) (comp-func-int-spec func) (interactive-form byte-func) (comp-func-c-name func) c-name (comp-func-lap func) lap commit ea35a62e6e200f00e22828a7d0994ee2a4d2fc6a Author: Andrea Corallo Date: Sat Aug 29 15:15:46 2020 +0200 * test/src/comp-tests.el (comp-tests-doc): Update test. diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 33b307b1c6..2a078be8cb 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -322,7 +322,9 @@ Check that the resulting binaries do not differ." (ert-deftest comp-tests-doc () (should (string= (documentation #'comp-tests-doc-f) "A nice docstring")) - (should (string-match "\\.*.eln\\'" (symbol-file #'comp-tests-doc-f)))) + ;; Check a preloaded function, we can't use `comp-tests-doc-f' now + ;; as this is loaded manually with no .elc. + (should (string-match "\\.*.elc\\'" (symbol-file #'error)))) (ert-deftest comp-test-interactive-form () (should (equal (interactive-form #'comp-test-interactive-form0-f) commit 59a40b0d75526c973b5bdd25c41824879aafa515 Author: Andrea Corallo Date: Sat Aug 29 15:10:37 2020 +0200 * lisp/startup.el (command-line): Clean-up logic for new .eln disposition. diff --git a/lisp/startup.el b/lisp/startup.el index 0a81c878af..e39df7568c 100644 --- a/lisp/startup.el +++ b/lisp/startup.el @@ -1059,12 +1059,7 @@ please check its value") (unless (file-readable-p lispdir) (princ (format "Lisp directory %s not readable?" lispdir)) (terpri))) - (setq lisp-dir - (file-truename - (if (string-match "\\.eln\\'" simple-file-name) - (expand-file-name - (concat (file-name-directory simple-file-name) "../")) - (file-name-directory simple-file-name)))) + (setq lisp-dir (file-truename (file-name-directory simple-file-name))) (setq load-history (mapcar (lambda (elt) (if (and (stringp (car elt)) commit 87b9c3e71840f480c2ce05eb51d71156790a5434 Author: Andrea Corallo Date: Sat Aug 29 11:29:01 2020 +0200 Have .elc files in `load-history' when loading native code (bug#43089) * src/lread.c (Fload): Add the corresponding .elc file to `load-history' when loading native code. * lisp/subr.el (eval-after-load): Use `load-file-name' instead of `load-true-file-name'. diff --git a/lisp/subr.el b/lisp/subr.el index 6e86601550..b020d09280 100644 --- a/lisp/subr.el +++ b/lisp/subr.el @@ -4613,10 +4613,10 @@ This function makes or adds to an entry on `after-load-alist'." ;; So add an indirection to make sure that `func' is really run ;; "after-load" in case the provide call happens early. (lambda () - (if (not load-true-file-name) + (if (not load-file-name) ;; Not being provided from a file, run func right now. (funcall func) - (let ((lfn load-true-file-name) + (let ((lfn load-file-name) ;; Don't use letrec, because equal (in ;; add/remove-hook) would get trapped in a cycle. (fun (make-symbol "eval-after-load-helper"))) diff --git a/src/lread.c b/src/lread.c index 326af307f9..ac5b2838ee 100644 --- a/src/lread.c +++ b/src/lread.c @@ -1322,10 +1322,23 @@ Return t if the file exists and loads successfully. */) specbind (Qlexical_binding, Qnil); /* Get the name for load-history. */ + Lisp_Object found_for_hist; + if (is_native_elisp) + { + /* Reconstruct the .elc filename. */ + Lisp_Object src_name = Fgethash (Ffile_name_nondirectory (found), + Vcomp_eln_to_el_h, Qnil); + if (suffix_p (src_name, "el.gz")) + src_name = Fsubstring (src_name, make_fixnum (0), make_fixnum (-3)); + found_for_hist = concat2 (src_name, build_string ("c")); + } + else + found_for_hist = found; + hist_file_name = (! NILP (Vpurify_flag) ? concat2 (Ffile_name_directory (file), - Ffile_name_nondirectory (found)) - : found) ; + Ffile_name_nondirectory (found_for_hist)) + : found_for_hist); version = -1; @@ -1504,13 +1517,6 @@ Return t if the file exists and loads successfully. */) { #ifdef HAVE_NATIVE_COMP specbind (Qcurrent_load_list, Qnil); - if (!NILP (Vpurify_flag)) - { - Lisp_Object base = concat2 (parent_directory (Vinvocation_directory), - build_string ("lisp/")); - Lisp_Object offset = Flength (base); - hist_file_name = Fsubstring (found, offset, Qnil); - } LOADHIST_ATTACH (hist_file_name); Fnative_elisp_load (found, Qnil); build_load_history (hist_file_name, true); commit 38b0ead7c1a8475bef7f811b07beed2c23cbc593 Author: Andrea Corallo Date: Sat Aug 29 10:15:55 2020 +0200 * Back using `load-file-name' when reading '#$' (bug#42961) * src/lread.c (read1, read_list): Use again load-file-name when reading '#$'. (syms_of_lread): Update `load-file-name' doc. diff --git a/src/lread.c b/src/lread.c index 5b77868a63..326af307f9 100644 --- a/src/lread.c +++ b/src/lread.c @@ -3261,7 +3261,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list) goto retry; } if (c == '$') - return Vload_true_file_name; + return Vload_file_name; if (c == '\'') return list2 (Qfunction, read0 (readcharfun)); /* #:foo is the uninterned symbol named foo. */ @@ -4062,7 +4062,7 @@ read_list (bool flag, Lisp_Object readcharfun) first_in_list = 0; /* While building, if the list starts with #$, treat it specially. */ - if (EQ (elt, Vload_true_file_name) + if (EQ (elt, Vload_file_name) && ! NILP (elt) && !NILP (Vpurify_flag)) { @@ -4083,7 +4083,7 @@ read_list (bool flag, Lisp_Object readcharfun) elt = concat2 (dot_dot_lisp, Ffile_name_nondirectory (elt)); } } - else if (EQ (elt, Vload_true_file_name) + else if (EQ (elt, Vload_file_name) && ! NILP (elt) && load_force_doc_strings) doc_reference = 2; @@ -5039,8 +5039,10 @@ directory. These file names are converted to absolute at startup. */); DEFVAR_LISP ("load-file-name", Vload_file_name, doc: /* Full name of file being loaded by `load'. -In case a .eln file is being loaded this is unreliable and `load-true-file-name' -should be used instead. */); + +In case of native code being loaded this is indicating the +corresponding bytecode filename. Use `load-true-file-name' to obtain +the .eln filename. */); Vload_file_name = Qnil; DEFVAR_LISP ("load-true-file-name", Vload_true_file_name, commit 696ab2eb17cf8850a65814f428287848b7d23d64 Author: Andrea Corallo Date: Fri Aug 28 18:37:44 2020 +0200 * src/lread.c (Fload): Bind load-file-name to the .elc filename. diff --git a/src/lread.c b/src/lread.c index 3d0de49560..5b77868a63 100644 --- a/src/lread.c +++ b/src/lread.c @@ -1477,8 +1477,10 @@ Return t if the file exists and loads successfully. */) same folder of their respective sources therfore not to break packages we fake `load-file-name' here. The non faked version of it is `load-true-file-name'. */ - specbind (Qload_file_name, Fgethash (Ffile_name_nondirectory (found), - Vcomp_eln_to_el_h, Qnil)); + Lisp_Object el_name = Fgethash (Ffile_name_nondirectory (found), + Vcomp_eln_to_el_h, Qnil); + specbind (Qload_file_name, + NILP (el_name) ? Qnil : concat2 (el_name, build_string ("c"))); } else specbind (Qload_file_name, found); commit c3514a6274cd6c6ddf2c133ccc708b7875aab90e Merge: aa526c9470 7d5807277f Author: Andrea Corallo Date: Sat Aug 29 11:33:37 2020 +0200 Merge remote-tracking branch 'savannah/master' into HEAD commit aa526c9470d679e9144af55d9e56928a111d2ceb Merge: 337367a733 51acfeef6a Author: Andrea Corallo Date: Wed Aug 26 21:40:00 2020 +0200 Merge branch 'add_driver_option' into HEAD commit 51acfeef6a5cf4dce2c80f56fbe0d8b0aa3d660c Author: Andrea Corallo Date: Mon Aug 24 10:28:59 2020 +0200 * Init gcc_jit_context_add_driver_option as optional * src/comp.c (init_gccjit_functions): Use LOAD_DLL_FN_OPT to init 'gcc_jit_context_add_driver_option' as this is optional. diff --git a/src/comp.c b/src/comp.c index a553a4bc7e..e6fa10cf55 100644 --- a/src/comp.c +++ b/src/comp.c @@ -259,7 +259,6 @@ init_gccjit_functions (void) LOAD_DLL_FN (library, gcc_jit_block_end_with_return); LOAD_DLL_FN (library, gcc_jit_block_end_with_void_return); LOAD_DLL_FN (library, gcc_jit_context_acquire); - LOAD_DLL_FN (library, gcc_jit_context_add_driver_option); LOAD_DLL_FN (library, gcc_jit_context_compile_to_file); LOAD_DLL_FN (library, gcc_jit_context_dump_reproducer_to_file); LOAD_DLL_FN (library, gcc_jit_context_dump_to_file); @@ -305,6 +304,7 @@ init_gccjit_functions (void) LOAD_DLL_FN (library, gcc_jit_struct_as_type); LOAD_DLL_FN (library, gcc_jit_struct_set_fields); LOAD_DLL_FN (library, gcc_jit_type_get_pointer); + LOAD_DLL_FN_OPT (library, gcc_jit_context_add_driver_option); LOAD_DLL_FN_OPT (library, gcc_jit_version_major); LOAD_DLL_FN_OPT (library, gcc_jit_version_minor); LOAD_DLL_FN_OPT (library, gcc_jit_version_patchlevel); commit 63f041c0a467e49599facf8a6992dcc20ef71eaf Author: Andrea Corallo Date: Mon Aug 24 10:27:40 2020 +0200 * Rename comp-native-driver-options-available-p * src/comp.c (Fcomp_native_driver_options_effective_p) Rename plus better doc. (add_driver_options, syms_of_comp): Rename `comp-native-driver-options-available-p' into comp-native-driver-options-effective-p. diff --git a/src/comp.c b/src/comp.c index 7f6bbe395b..a553a4bc7e 100644 --- a/src/comp.c +++ b/src/comp.c @@ -4122,10 +4122,12 @@ DEFUN ("comp--release-ctxt", Fcomp__release_ctxt, Scomp__release_ctxt, return Qt; } -DEFUN ("comp-native-driver-options-available-p", Fcomp_native_driver_options_available_p, - Scomp_native_driver_options_available_p, +DEFUN ("comp-native-driver-options-effective-p", + Fcomp_native_driver_options_effective_p, + Scomp_native_driver_options_effective_p, 0, 0, 0, - doc: /* Return t if `comp-native-driver-options' can be used. */) + doc: /* Return t if `comp-native-driver-options' is + effective nil otherwise. */) (void) { #if defined (LIBGCCJIT_HAVE_gcc_jit_context_add_driver_option) \ @@ -4147,7 +4149,7 @@ add_driver_options (void) #if defined (LIBGCCJIT_HAVE_gcc_jit_context_add_driver_option) \ || defined (WINDOWSNT) load_gccjit_if_necessary (true); - if (!NILP (Fcomp_native_driver_options_available_p ())) + if (!NILP (Fcomp_native_driver_options_effective_p ())) FOR_EACH_TAIL (options) gcc_jit_context_add_driver_option (comp.ctxt, SSDATA (XCAR (options))); @@ -5139,7 +5141,7 @@ native compiled one. */); "configuration, please recompile")); defsubr (&Scomp_el_to_eln_filename); - defsubr (&Scomp_native_driver_options_available_p); + defsubr (&Scomp_native_driver_options_effective_p); defsubr (&Scomp__init_ctxt); defsubr (&Scomp__release_ctxt); defsubr (&Scomp__compile_ctxt_to_file); commit f8321f07ce874e9c7294cdb8e15f8a08ba064aa7 Author: Andrea Corallo Date: Mon Aug 24 10:25:36 2020 +0200 * src/comp.c (add_driver_options): Fix missing condition + clean-up pragma diff --git a/src/comp.c b/src/comp.c index 5bfbfbaf3c..7f6bbe395b 100644 --- a/src/comp.c +++ b/src/comp.c @@ -4146,13 +4146,12 @@ add_driver_options (void) #if defined (LIBGCCJIT_HAVE_gcc_jit_context_add_driver_option) \ || defined (WINDOWSNT) -#pragma GCC diagnostic ignored "-Waddress" load_gccjit_if_necessary (true); - FOR_EACH_TAIL (options) - gcc_jit_context_add_driver_option (comp.ctxt, - SSDATA (XCAR (options))); + if (!NILP (Fcomp_native_driver_options_available_p ())) + FOR_EACH_TAIL (options) + gcc_jit_context_add_driver_option (comp.ctxt, + SSDATA (XCAR (options))); return; -#pragma GCC diagnostic pop #endif if (CONSP (options)) xsignal1 (Qnative_compiler_error, commit c17013ae766d7d3dd79122e1ee99d3f2ec4d9f04 Author: Andreas Fuchs Date: Thu Aug 20 21:05:37 2020 -0400 * Add 'comp-native-driver-options-available-p' * src/comp.c (comp-native-driver-options-available-p): New function that returns t if driver options can be used. diff --git a/src/comp.c b/src/comp.c index 6cde761f76..5bfbfbaf3c 100644 --- a/src/comp.c +++ b/src/comp.c @@ -4122,6 +4122,23 @@ DEFUN ("comp--release-ctxt", Fcomp__release_ctxt, Scomp__release_ctxt, return Qt; } +DEFUN ("comp-native-driver-options-available-p", Fcomp_native_driver_options_available_p, + Scomp_native_driver_options_available_p, + 0, 0, 0, + doc: /* Return t if `comp-native-driver-options' can be used. */) + (void) +{ +#if defined (LIBGCCJIT_HAVE_gcc_jit_context_add_driver_option) \ + || defined (WINDOWSNT) +#pragma GCC diagnostic ignored "-Waddress" + if (gcc_jit_context_add_driver_option) + return Qt; +#pragma GCC diagnostic pop +#endif + return Qnil; +} + + static void add_driver_options (void) { @@ -5123,6 +5140,7 @@ native compiled one. */); "configuration, please recompile")); defsubr (&Scomp_el_to_eln_filename); + defsubr (&Scomp_native_driver_options_available_p); defsubr (&Scomp__init_ctxt); defsubr (&Scomp__release_ctxt); defsubr (&Scomp__compile_ctxt_to_file); commit 1f105d5554e37a0c4994806a0f910c6686f2014d Author: Andrea Corallo Date: Wed Aug 19 17:47:37 2020 +0200 * Improve 'add_driver_options' * src/comp.c (add_driver_options): Use load_gccjit_if_necessary and FOR_EACH_TAIL + GNU style. diff --git a/src/comp.c b/src/comp.c index 03409cba0c..6cde761f76 100644 --- a/src/comp.c +++ b/src/comp.c @@ -4130,27 +4130,19 @@ add_driver_options (void) #if defined (LIBGCCJIT_HAVE_gcc_jit_context_add_driver_option) \ || defined (WINDOWSNT) #pragma GCC diagnostic ignored "-Waddress" - if (gcc_jit_context_add_driver_option) - { - while (CONSP (options)) - { - gcc_jit_context_add_driver_option (comp.ctxt, - SSDATA (XCAR (options))); - options = XCDR (options); - } - - return; - } + load_gccjit_if_necessary (true); + FOR_EACH_TAIL (options) + gcc_jit_context_add_driver_option (comp.ctxt, + SSDATA (XCAR (options))); + return; #pragma GCC diagnostic pop #endif if (CONSP (options)) - { - xsignal1 (Qnative_compiler_error, - build_string ("Customizing native compiler options" - " via `comp-native-driver-options' is" - " only available on libgccjit version 9" - " and above.")); - } + xsignal1 (Qnative_compiler_error, + build_string ("Customizing native compiler options" + " via `comp-native-driver-options' is" + " only available on libgccjit version 9" + " and above.")); } static void commit c00aedb4a591fc19818ad28846b7cf03c744a730 Author: Andreas Fuchs Date: Wed Aug 19 08:16:50 2020 -0400 Fix windows NT handling for [...]_add_driver_options * Instead of conditionalizing on the wrong preprocessor flag, now use the right one: LIBGCCJIT_HAVE_gcc_jit_context_add_driver_option * Also perform the driver-option-adding step on win NT, but only if the function is non-NULL. * Make the function declaration for add_driver_options non-old-style. diff --git a/src/comp.c b/src/comp.c index 97a5665870..03409cba0c 100644 --- a/src/comp.c +++ b/src/comp.c @@ -4123,23 +4123,34 @@ DEFUN ("comp--release-ctxt", Fcomp__release_ctxt, Scomp__release_ctxt, } static void -add_driver_options () +add_driver_options (void) { Lisp_Object options = Fsymbol_value (Qcomp_native_driver_options); -#ifdef LIBGCCJIT_HAVE_gcc_jit_context_add_command_line_option - while (CONSP (options)) +#if defined (LIBGCCJIT_HAVE_gcc_jit_context_add_driver_option) \ + || defined (WINDOWSNT) +#pragma GCC diagnostic ignored "-Waddress" + if (gcc_jit_context_add_driver_option) { - gcc_jit_context_add_driver_option (comp.ctxt, SSDATA (XCAR (options))); - options = XCDR (options); + while (CONSP (options)) + { + gcc_jit_context_add_driver_option (comp.ctxt, + SSDATA (XCAR (options))); + options = XCDR (options); + } + + return; } -#else +#pragma GCC diagnostic pop +#endif if (CONSP (options)) { xsignal1 (Qnative_compiler_error, - build_string ("Customizing native compiler options via `comp-native-driver-options' is only available on libgccjit version 9 and above.")); + build_string ("Customizing native compiler options" + " via `comp-native-driver-options' is" + " only available on libgccjit version 9" + " and above.")); } -#endif } static void commit 2772e835b61774ca83cbd2bf79c2534b2d1c6f49 Author: Andreas Fuchs Date: Mon Aug 10 09:48:57 2020 -0400 Set native driver options in async compiles, also Ensure the variable is set to the value that was customized in the parent process in child compilation processes, also. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 37559c20dd..75c51b03ec 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2591,6 +2591,8 @@ display a message." comp-debug ,comp-debug comp-verbose ,comp-verbose comp-eln-load-path ',comp-eln-load-path + comp-native-driver-options + ',comp-native-driver-options load-path ',load-path) ,comp-async-env-modifier-form (message "Compiling %s..." ,source-file) commit 337367a733e107df1ecb89955f0a249491bc62d9 Author: Andrea Corallo Date: Sun Aug 23 12:36:07 2020 +0200 * lisp/emacs-lisp/comp.el (native-compile): Fix free function compilation. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 3176351b37..28dbd56747 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2654,11 +2654,11 @@ Return the compilation unit file name." (byte-compile-debug t) (comp-ctxt (make-comp-ctxt - :output (comp-el-to-eln-filename (if (symbolp function-or-file) - (symbol-name function-or-file) - function-or-file) - (when byte-native-for-bootstrap - (car (last comp-eln-load-path)))) + :output (if (symbolp function-or-file) + (make-temp-file (symbol-name function-or-file) nil ".eln") + (comp-el-to-eln-filename function-or-file + (when byte-native-for-bootstrap + (car (last comp-eln-load-path))))) :with-late-load with-late-load))) (comp-log "\n \n" 1) (condition-case err commit 6088d199595d102ad6701512560322e74e181d27 Author: Andrea Corallo Date: Sun Aug 23 11:31:31 2020 +0200 * A cc-mode fix to be compiled correctly once installed * lisp/progmodes/cc-bytecomp.el (cc-bytecomp-load): If cc-mode is not compiled during the initial build (read NATIVE_FAST_BOOT) it will be when already in el.gz form. diff --git a/lisp/progmodes/cc-bytecomp.el b/lisp/progmodes/cc-bytecomp.el index 5eb8af2534..ad884288a6 100644 --- a/lisp/progmodes/cc-bytecomp.el +++ b/lisp/progmodes/cc-bytecomp.el @@ -286,7 +286,9 @@ perhaps a `cc-bytecomp-restore-environment' is forgotten somewhere")) (cons cc-file cc-bytecomp-loaded-files)) (cc-bytecomp-debug-msg "cc-bytecomp-load: Loading %S" cc-file) - (load cc-file nil t t) + ;; native-comp may async compile also intalled el.gz + ;; files therefore we may have to load here other el.gz. + (load cc-part nil t) (cc-bytecomp-debug-msg "cc-bytecomp-load: Loaded %S" cc-file))) (cc-bytecomp-setup-environment) commit 5f5d664c734414597c1c7d9981b1ceb9ff69c5b1 Author: Andrea Corallo Date: Sat Aug 22 11:11:21 2020 +0200 Rework eln hash filename strategy Generate eln filename hashing also the source file content in the form: /absolute/path/filename.el + content -> eln-cache/filename-path_hash-content_hash.eln * src/lread.c (maybe_swap_for_eln): Always call Fcomp_el_to_eln_filename on an existing source file. * src/comp.c (md5.h, sysstdio.h, zlib.h): New include. (comp_hash_string): Use md5 instead of sha512. (MD5_BLOCKSIZE): New macro. (accumulate_and_process_md5, final_process_md5, md5_gz_stream) (comp_hash_source_file): New functions. (Fcomp_el_to_eln_filename): Rework for hasing using also source file content. * src/lread.c (maybe_swap_for_eln): Rename el_name -> src_name as this can be also a have .el.gz extention. diff --git a/configure.ac b/configure.ac index 0582b2f61c..cdc18eab19 100644 --- a/configure.ac +++ b/configure.ac @@ -3787,6 +3787,12 @@ Here instructions on how to compile and install libgccjit from source: HAVE_NATIVE_COMP=no LIBGCCJIT_LIB= if test "${with_nativecomp}" != "no"; then + if test "${HAVE_PDUMPER}" = no; then + AC_MSG_ERROR(['--with-nativecomp' requires '--with-dumping=pdumper']) + fi + if test "${HAVE_ZLIB}" = no; then + AC_MSG_ERROR(['--with-nativecomp' requires zlib]) + fi emacs_save_LIBS=$LIBS LIBS="-lgccjit" AC_RUN_IFELSE([libgccjit_smoke_test], [], [libgccjit_broken], @@ -3800,9 +3806,6 @@ if test "${with_nativecomp}" != "no"; then NEED_DYNLIB=yes AC_DEFINE(HAVE_NATIVE_COMP, 1, [Define to 1 if you have the libgccjit library (-lgccjit).]) fi -if test "${HAVE_NATIVE_COMP}" = yes && test "${HAVE_PDUMPER}" = no; then - AC_MSG_ERROR(['--with-nativecomp' requires '--with-dumping=pdumper']) -fi AC_DEFINE_UNQUOTED(NATIVE_ELISP_SUFFIX, ".eln", [System extension for native compiled elisp]) AC_SUBST(HAVE_NATIVE_COMP) diff --git a/lib/Makefile.in b/lib/Makefile.in index 06d8e56421..8d97d3bcfb 100644 --- a/lib/Makefile.in +++ b/lib/Makefile.in @@ -50,12 +50,18 @@ am__v_at_ = $(am__v_at_@AM_DEFAULT_V@) am__v_at_0 = @ am__v_at_1 = +HAVE_NATIVE_COMP = @HAVE_NATIVE_COMP@ + ALL_CFLAGS= \ $(C_SWITCH_SYSTEM) $(C_SWITCH_MACHINE) $(DEPFLAGS) \ $(GNULIB_WARN_CFLAGS) $(WERROR_CFLAGS) $(PROFILING_CFLAGS) $(CFLAGS) \ -I. -I../src -I$(srcdir) -I$(srcdir)/../src \ $(if $(patsubst e-%,,$(notdir $<)),,-Demacs) +ifeq ($(HAVE_NATIVE_COMP),yes) +ALL_CFLAGS += -DGL_COMPILE_CRYPTO_STREAM +endif + SYSTEM_TYPE = @SYSTEM_TYPE@ ifeq ($(SYSTEM_TYPE),windows-nt) include $(srcdir)/../nt/gnulib-cfg.mk diff --git a/src/comp.c b/src/comp.c index ff73245b8d..5f1257f6be 100644 --- a/src/comp.c +++ b/src/comp.c @@ -36,7 +36,9 @@ along with GNU Emacs. If not, see . */ #include "dynlib.h" #include "buffer.h" #include "blockinput.h" -#include "sha512.h" +#include "md5.h" +#include "sysstdio.h" +#include "zlib.h" /********************************/ @@ -394,8 +396,6 @@ load_gccjit_if_necessary (bool mandatory) } -#define ELN_FILENAME_HASH_LEN 64 - /* C symbols emitted for the load relocation mechanism. */ #define CURRENT_THREAD_RELOC_SYM "current_thread_reloc" #define PURE_RELOC_SYM "pure_reloc" @@ -640,9 +640,123 @@ format_string (const char *format, ...) static Lisp_Object comp_hash_string (Lisp_Object string) { - Lisp_Object digest = make_uninit_string (SHA512_DIGEST_SIZE * 2); - sha512_buffer (SSDATA (string), SCHARS (string), SSDATA (digest)); - hexbuf_digest (SSDATA (digest), SDATA (digest), SHA512_DIGEST_SIZE); + Lisp_Object digest = make_uninit_string (MD5_DIGEST_SIZE * 2); + md5_buffer (SSDATA (string), SCHARS (string), SSDATA (digest)); + hexbuf_digest (SSDATA (digest), SDATA (digest), MD5_DIGEST_SIZE); + + return digest; +} + +#define MD5_BLOCKSIZE 32768 /* From md5.c */ + +static char acc_buff[2 * MD5_BLOCKSIZE]; +static size_t acc_size; + +static void +accumulate_and_process_md5 (void *data, size_t len, struct md5_ctx *ctxt) +{ + eassert (len <= MD5_BLOCKSIZE); + /* We may optimize this saving some of these memcpy/move using + directly the outer buffers but so far I'll not bother. */ + memcpy (acc_buff + acc_size, data, len); + acc_size += len; + if (acc_size >= MD5_BLOCKSIZE) + { + acc_size -= MD5_BLOCKSIZE; + md5_process_block (acc_buff, MD5_BLOCKSIZE, ctxt); + memmove (acc_buff, acc_buff + MD5_BLOCKSIZE, acc_size); + } +} + +static void +final_process_md5 (struct md5_ctx *ctxt) +{ + if (acc_size) + { + md5_process_bytes (acc_buff, acc_size, ctxt); + acc_size = 0; + } +} + +static int +md5_gz_stream (FILE *source, void *resblock) +{ + z_stream stream; + unsigned char in[MD5_BLOCKSIZE]; + unsigned char out[MD5_BLOCKSIZE]; + + eassert (!acc_size); + + struct md5_ctx ctx; + md5_init_ctx (&ctx); + + /* allocate inflate state */ + stream.zalloc = Z_NULL; + stream.zfree = Z_NULL; + stream.opaque = Z_NULL; + stream.avail_in = 0; + stream.next_in = Z_NULL; + int res = inflateInit2 (&stream, MAX_WBITS + 32); + if (res != Z_OK) + return -1; + + do { + stream.avail_in = fread (in, 1, MD5_BLOCKSIZE, source); + if (ferror (source)) { + inflateEnd (&stream); + return -1; + } + if (stream.avail_in == 0) + break; + stream.next_in = in; + + do { + stream.avail_out = MD5_BLOCKSIZE; + stream.next_out = out; + res = inflate (&stream, Z_NO_FLUSH); + + if (res != Z_OK && res != Z_STREAM_END) + return -1; + + accumulate_and_process_md5 (out, MD5_BLOCKSIZE - stream.avail_out, &ctx); + } while (!stream.avail_out); + + } while (res != Z_STREAM_END); + + final_process_md5 (&ctx); + inflateEnd (&stream); + + if (res != Z_STREAM_END) + return -1; + + md5_finish_ctx (&ctx, resblock); + + return 0; +} +#undef MD5_BLOCKSIZE + +static Lisp_Object +comp_hash_source_file (Lisp_Object filename) +{ + /* Can't use Finsert_file_contents + Fbuffer_hash as this is called + by Fcomp_el_to_eln_filename too early during bootstrap. */ + bool is_gz = suffix_p (filename, ".gz"); + FILE *f = emacs_fopen (SSDATA (filename), is_gz ? "rb" : "r"); + + if (!f) + report_file_error ("Opening source file", filename); + + Lisp_Object digest = make_uninit_string (MD5_DIGEST_SIZE * 2); + + int res = is_gz + ? md5_gz_stream (f, SSDATA (digest)) + : md5_stream (f, SSDATA (digest)); + fclose (f); + + if (res) + xsignal2 (Qfile_notify_error, build_string ("hashing failed"), filename); + + hexbuf_digest (SSDATA (digest), SSDATA (digest), MD5_DIGEST_SIZE); return digest; } @@ -3872,21 +3986,36 @@ If BASE-DIR is nil use the first entry in `comp-eln-load-path'. */) { CHECK_STRING (filename); + filename = Fexpand_file_name (filename, Qnil); + + if (NILP (Ffile_exists_p (filename))) + xsignal1 (Qfile_missing, filename); + + Lisp_Object content_hash = comp_hash_source_file (filename); + if (suffix_p (filename, ".gz")) filename = Fsubstring (filename, Qnil, make_fixnum (-3)); - filename = Fexpand_file_name (filename, Qnil); /* We create eln filenames with an hash in order to look-up these starting from the source filename, IOW have a relation - /absolute/path/filename.el -> eln-cache/filename-hash.eln. + + /absolute/path/filename.el + content -> + eln-cache/filename-path_hash-content_hash.eln. + + 'dlopen' can return the same handle if two shared with the same + filename are loaded in two different times (even if the first was + deleted!). To prevent this scenario the source file content is + included in the hashing algorithm. + + As at any point in time no more then one file can exist with the + same filename, should be possibile to clean up all + filename-path_hash-* except the most recent one (or the new one + being recompiled). As installing .eln files compiled during the build changes their absolute path we need an hashing mechanism that is not sensitive to that. For this we replace if match PATH_DUMPLOADSEARCH or - PATH_LOADSEARCH with '//' before generating the hash. - - Another approach would be to hash using the source file content - but this may have a measurable performance impact. */ + PATH_LOADSEARCH with '//' before generating the hash. */ if (NILP (loadsearch_re_list)) { @@ -3909,12 +4038,12 @@ If BASE-DIR is nil use the first entry in `comp-eln-load-path'. */) break; } } - - Lisp_Object hash = Fsubstring (comp_hash_string (filename), Qnil, - make_fixnum (ELN_FILENAME_HASH_LEN)); + Lisp_Object separator = build_string ("-"); + Lisp_Object path_hash = comp_hash_string (filename); filename = concat2 (Ffile_name_nondirectory (Fsubstring (filename, Qnil, make_fixnum (-3))), - build_string ("-")); + separator); + Lisp_Object hash = concat3 (path_hash, separator, content_hash); filename = concat3 (filename, hash, build_string (NATIVE_ELISP_SUFFIX)); if (NILP (base_dir)) base_dir = XCAR (Vcomp_eln_load_path); diff --git a/src/lread.c b/src/lread.c index 521da4e1d8..3d0de49560 100644 --- a/src/lread.c +++ b/src/lread.c @@ -1623,10 +1623,17 @@ maybe_swap_for_eln (Lisp_Object *filename, int *fd, struct timespec mtime) Lisp_Object eln_path_tail = Vcomp_eln_load_path; FOR_EACH_TAIL_SAFE (eln_path_tail) { - Lisp_Object el_name = + Lisp_Object src_name = Fsubstring (*filename, Qnil, make_fixnum (-1)); + if (NILP (Ffile_exists_p (src_name))) + { + src_name = concat2 (src_name, build_string (".gz")); + if (NILP (Ffile_exists_p (src_name))) + /* Can't find the corresponding source file. */ + return; + } Lisp_Object eln_name = - Fcomp_el_to_eln_filename (el_name, XCAR (eln_path_tail)); + Fcomp_el_to_eln_filename (src_name, XCAR (eln_path_tail)); int eln_fd = emacs_open (SSDATA (ENCODE_FILE (eln_name)), O_RDONLY, 0); if (eln_fd > 0) @@ -1643,7 +1650,7 @@ maybe_swap_for_eln (Lisp_Object *filename, int *fd, struct timespec mtime) *fd = eln_fd; /* Store the eln -> el relation. */ Fputhash (Ffile_name_nondirectory (eln_name), - el_name, Vcomp_eln_to_el_h); + src_name, Vcomp_eln_to_el_h); return; } else commit 9baa0296aaca6ff1b547817a4eba5d8740ae3e5e Author: Andrea Corallo Date: Sat Aug 22 10:28:17 2020 +0200 * Import lib/af_alg.h from gnulib * lib/af_alg.h: New file. diff --git a/lib/af_alg.h b/lib/af_alg.h new file mode 100644 index 0000000000..4c5854cc99 --- /dev/null +++ b/lib/af_alg.h @@ -0,0 +1,115 @@ +/* af_alg.h - Compute message digests from file streams and buffers. + Copyright (C) 2018-2020 Free Software Foundation, Inc. + + This program is free software; you can redistribute it and/or modify it + under the terms of the GNU General Public License as published by the + Free Software Foundation; either version 2, or (at your option) any + later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, see . */ + +/* Written by Matteo Croce , 2018. + Documentation by Bruno Haible , 2018. */ + +/* Declare specific functions for computing message digests + using the Linux kernel crypto API, if available. This kernel API gives + access to specialized crypto instructions (that would also be available + in user space) or to crypto devices (not directly available in user space). + + For a more complete set of facilities that use the Linux kernel crypto API, + look at libkcapi. */ + +#ifndef AF_ALG_H +# define AF_ALG_H 1 + +# include +# include + +# ifdef __cplusplus +extern "C" { +# endif + +# if USE_LINUX_CRYPTO_API + +/* Compute a message digest of a memory region. + + The memory region starts at BUFFER and is LEN bytes long. + + ALG is the message digest algorithm; see the file /proc/crypto. + + RESBLOCK points to a block of HASHLEN bytes, for the result. + HASHLEN must be the length of the message digest, in bytes, in particular: + + alg | hashlen + -------+-------- + md5 | 16 + sha1 | 20 + sha224 | 28 + sha256 | 32 + sha384 | 48 + sha512 | 64 + + If successful, fill RESBLOCK and return 0. + Upon failure, return a negated error number. */ +int +afalg_buffer (const char *buffer, size_t len, const char *alg, + void *resblock, ssize_t hashlen); + +/* Compute a message digest of data read from STREAM. + + STREAM is an open file stream. The last operation on STREAM should + not be 'ungetc', and if STREAM is also open for writing it should + have been fflushed since its last write. Read from the current + position to the end of STREAM. Handle regular files efficiently. + + ALG is the message digest algorithm; see the file /proc/crypto. + + RESBLOCK points to a block of HASHLEN bytes, for the result. + HASHLEN must be the length of the message digest, in bytes, in particular: + + alg | hashlen + -------+-------- + md5 | 16 + sha1 | 20 + sha224 | 28 + sha256 | 32 + sha384 | 48 + sha512 | 64 + + If successful, fill RESBLOCK and return 0. + Upon failure, return a negated error number. + Unless returning 0 or -EIO, restore STREAM's file position so that + the caller can fall back on some other method. */ +int +afalg_stream (FILE *stream, const char *alg, + void *resblock, ssize_t hashlen); + +# else + +static inline int +afalg_buffer (const char *buffer, size_t len, const char *alg, + void *resblock, ssize_t hashlen) +{ + return -EAFNOSUPPORT; +} + +static inline int +afalg_stream (FILE *stream, const char *alg, + void *resblock, ssize_t hashlen) +{ + return -EAFNOSUPPORT; +} + +# endif + +# ifdef __cplusplus +} +# endif + +#endif /* AF_ALG_H */ commit fafc9c21175ee50df84114a09e9f43f02c960b85 Merge: c818c29771 4e97019a77 Author: Andrea Corallo Date: Sun Aug 23 11:52:18 2020 +0200 Merge remote-tracking branch 'savannah/master' into HEAD commit c818c29771d3cb51875643b2f6c894073e429dd2 Author: Andrea Corallo Date: Thu Aug 20 12:36:39 2020 +0200 Revert "Fix native code uneffective loads after recompilation" (bug#42944) This reverts commit 8a931a97b8dd19a38d6f719f810280a07ba76438. This introduced bug#42944. diff --git a/src/comp.c b/src/comp.c index a00088bb7f..ff73245b8d 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3872,26 +3872,13 @@ If BASE-DIR is nil use the first entry in `comp-eln-load-path'. */) { CHECK_STRING (filename); - if (NILP (Ffile_exists_p (filename))) - xsignal1 (Qfile_missing, filename); - - Lisp_Object last_mod_time = - Fnth (make_fixnum (5), Ffile_attributes (filename, Qnil)); - if (suffix_p (filename, ".gz")) filename = Fsubstring (filename, Qnil, make_fixnum (-3)); filename = Fexpand_file_name (filename, Qnil); /* We create eln filenames with an hash in order to look-up these starting from the source filename, IOW have a relation - - /absolute/path/filename.el + last_mod_time -> - eln-cache/filename-hash.eln. - - 'dlopen' can return the same handle if two shared with the same - filename are loaded in two different times (even if the first was - deleted!). To prevent this scenario the last modification time - of the source file is included in the hashing algorithm. + /absolute/path/filename.el -> eln-cache/filename-hash.eln. As installing .eln files compiled during the build changes their absolute path we need an hashing mechanism that is not sensitive @@ -3923,9 +3910,7 @@ If BASE-DIR is nil use the first entry in `comp-eln-load-path'. */) } } - Lisp_Object hash_input = - concat2 (filename, Fprin1_to_string (last_mod_time, Qnil)); - Lisp_Object hash = Fsubstring (comp_hash_string (hash_input), Qnil, + Lisp_Object hash = Fsubstring (comp_hash_string (filename), Qnil, make_fixnum (ELN_FILENAME_HASH_LEN)); filename = concat2 (Ffile_name_nondirectory (Fsubstring (filename, Qnil, make_fixnum (-3))), diff --git a/src/lread.c b/src/lread.c index 6b585fcacc..521da4e1d8 100644 --- a/src/lread.c +++ b/src/lread.c @@ -1635,13 +1635,19 @@ maybe_swap_for_eln (Lisp_Object *filename, int *fd, struct timespec mtime) emacs_close (eln_fd); else { - *filename = eln_name; - emacs_close (*fd); - *fd = eln_fd; - /* Store the eln -> el relation. */ - Fputhash (Ffile_name_nondirectory (eln_name), - el_name, Vcomp_eln_to_el_h); - return; + struct timespec eln_mtime = get_stat_mtime (&eln_st); + if (timespec_cmp (eln_mtime, mtime) > 0) + { + *filename = eln_name; + emacs_close (*fd); + *fd = eln_fd; + /* Store the eln -> el relation. */ + Fputhash (Ffile_name_nondirectory (eln_name), + el_name, Vcomp_eln_to_el_h); + return; + } + else + emacs_close (eln_fd); } } } commit bec2adebc6a5c4984d52ea7e66a7a3632e7dc578 Author: Andreas Fuchs Date: Sat Aug 8 16:22:43 2020 -0400 Pass driver options to libgccjit where supported Add a customizable variable for driver options (such as linker flags) to pass to libgccjit (Bug #42761). * lisp/emacs-lisp/comp.el (comp-native-driver-options): New customization variable. * src/comp.c: Use comp-native-driver-options to set libgccjit's driver options, if supported on the library's ABI version. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 3176351b37..37559c20dd 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -134,6 +134,16 @@ before compilation. Usable to modify the compiler environment." :type 'list :group 'comp) +(defcustom comp-native-driver-options nil + "Options passed verbatim to the native compiler's backend driver. +Note that not all options are meaningful; typically only the options +affecting the assembler and linker are likely to be useful. + +Passing these options is only available in libgccjit version 9 +and above." + :type 'list + :group 'comp) + (defvar comp-dry-run nil "When non nil run everything but the C back-end.") diff --git a/src/comp.c b/src/comp.c index a00088bb7f..97a5665870 100644 --- a/src/comp.c +++ b/src/comp.c @@ -54,6 +54,7 @@ along with GNU Emacs. If not, see . */ #undef gcc_jit_block_end_with_return #undef gcc_jit_block_end_with_void_return #undef gcc_jit_context_acquire +#undef gcc_jit_context_add_driver_option #undef gcc_jit_context_compile_to_file #undef gcc_jit_context_dump_reproducer_to_file #undef gcc_jit_context_dump_to_file @@ -119,6 +120,8 @@ DEF_DLL_FN (const char *, gcc_jit_context_get_first_error, DEF_DLL_FN (gcc_jit_block *, gcc_jit_function_new_block, (gcc_jit_function *func, const char *name)); DEF_DLL_FN (gcc_jit_context *, gcc_jit_context_acquire, (void)); +DEF_DLL_FN (void, gcc_jit_context_add_driver_option, + (gcc_jit_context *ctxt, const char *optname)); DEF_DLL_FN (gcc_jit_field *, gcc_jit_context_new_field, (gcc_jit_context *ctxt, gcc_jit_location *loc, gcc_jit_type *type, const char *name)); @@ -256,6 +259,7 @@ init_gccjit_functions (void) LOAD_DLL_FN (library, gcc_jit_block_end_with_return); LOAD_DLL_FN (library, gcc_jit_block_end_with_void_return); LOAD_DLL_FN (library, gcc_jit_context_acquire); + LOAD_DLL_FN (library, gcc_jit_context_add_driver_option); LOAD_DLL_FN (library, gcc_jit_context_compile_to_file); LOAD_DLL_FN (library, gcc_jit_context_dump_reproducer_to_file); LOAD_DLL_FN (library, gcc_jit_context_dump_to_file); @@ -317,6 +321,7 @@ init_gccjit_functions (void) #define gcc_jit_block_end_with_return fn_gcc_jit_block_end_with_return #define gcc_jit_block_end_with_void_return fn_gcc_jit_block_end_with_void_return #define gcc_jit_context_acquire fn_gcc_jit_context_acquire +#define gcc_jit_context_add_driver_option fn_gcc_jit_context_add_driver_option #define gcc_jit_context_compile_to_file fn_gcc_jit_context_compile_to_file #define gcc_jit_context_dump_reproducer_to_file fn_gcc_jit_context_dump_reproducer_to_file #define gcc_jit_context_dump_to_file fn_gcc_jit_context_dump_to_file @@ -4117,6 +4122,26 @@ DEFUN ("comp--release-ctxt", Fcomp__release_ctxt, Scomp__release_ctxt, return Qt; } +static void +add_driver_options () +{ + Lisp_Object options = Fsymbol_value (Qcomp_native_driver_options); + +#ifdef LIBGCCJIT_HAVE_gcc_jit_context_add_command_line_option + while (CONSP (options)) + { + gcc_jit_context_add_driver_option (comp.ctxt, SSDATA (XCAR (options))); + options = XCDR (options); + } +#else + if (CONSP (options)) + { + xsignal1 (Qnative_compiler_error, + build_string ("Customizing native compiler options via `comp-native-driver-options' is only available on libgccjit version 9 and above.")); + } +#endif +} + static void restore_sigmask (void) { @@ -4186,6 +4211,8 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, for (ptrdiff_t i = 0; i < func_h->count; i++) compile_function (HASH_VALUE (func_h, i)); + add_driver_options (); + if (COMP_DEBUG) gcc_jit_context_dump_to_file (comp.ctxt, format_string ("%s.c", SSDATA (base_name)), @@ -4992,6 +5019,7 @@ native compiled one. */); DEFSYM (Qcomp_speed, "comp-speed"); DEFSYM (Qcomp_debug, "comp-debug"); + DEFSYM (Qcomp_native_driver_options, "comp-native-driver-options"); /* Limple instruction set. */ DEFSYM (Qcomment, "comment"); commit 8a931a97b8dd19a38d6f719f810280a07ba76438 Author: Andrea Corallo Date: Wed Aug 19 15:26:42 2020 +0200 Fix native code uneffective loads after recompilation 'dlopen' can return the same handle if two shared with the same filename are loaded in two different times (even if the first was deleted!). To prevent this scenario the last modification time of the source file is included in the hashing algorithm. * src/comp.c (Fcomp_el_to_eln_filename): Update hashing algo to include the source last modification date. * src/lread.c (maybe_swap_for_eln): Do not check for eln newer then elc as this is now unnecessary. diff --git a/src/comp.c b/src/comp.c index ff73245b8d..a00088bb7f 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3872,13 +3872,26 @@ If BASE-DIR is nil use the first entry in `comp-eln-load-path'. */) { CHECK_STRING (filename); + if (NILP (Ffile_exists_p (filename))) + xsignal1 (Qfile_missing, filename); + + Lisp_Object last_mod_time = + Fnth (make_fixnum (5), Ffile_attributes (filename, Qnil)); + if (suffix_p (filename, ".gz")) filename = Fsubstring (filename, Qnil, make_fixnum (-3)); filename = Fexpand_file_name (filename, Qnil); /* We create eln filenames with an hash in order to look-up these starting from the source filename, IOW have a relation - /absolute/path/filename.el -> eln-cache/filename-hash.eln. + + /absolute/path/filename.el + last_mod_time -> + eln-cache/filename-hash.eln. + + 'dlopen' can return the same handle if two shared with the same + filename are loaded in two different times (even if the first was + deleted!). To prevent this scenario the last modification time + of the source file is included in the hashing algorithm. As installing .eln files compiled during the build changes their absolute path we need an hashing mechanism that is not sensitive @@ -3910,7 +3923,9 @@ If BASE-DIR is nil use the first entry in `comp-eln-load-path'. */) } } - Lisp_Object hash = Fsubstring (comp_hash_string (filename), Qnil, + Lisp_Object hash_input = + concat2 (filename, Fprin1_to_string (last_mod_time, Qnil)); + Lisp_Object hash = Fsubstring (comp_hash_string (hash_input), Qnil, make_fixnum (ELN_FILENAME_HASH_LEN)); filename = concat2 (Ffile_name_nondirectory (Fsubstring (filename, Qnil, make_fixnum (-3))), diff --git a/src/lread.c b/src/lread.c index 521da4e1d8..6b585fcacc 100644 --- a/src/lread.c +++ b/src/lread.c @@ -1635,19 +1635,13 @@ maybe_swap_for_eln (Lisp_Object *filename, int *fd, struct timespec mtime) emacs_close (eln_fd); else { - struct timespec eln_mtime = get_stat_mtime (&eln_st); - if (timespec_cmp (eln_mtime, mtime) > 0) - { - *filename = eln_name; - emacs_close (*fd); - *fd = eln_fd; - /* Store the eln -> el relation. */ - Fputhash (Ffile_name_nondirectory (eln_name), - el_name, Vcomp_eln_to_el_h); - return; - } - else - emacs_close (eln_fd); + *filename = eln_name; + emacs_close (*fd); + *fd = eln_fd; + /* Store the eln -> el relation. */ + Fputhash (Ffile_name_nondirectory (eln_name), + el_name, Vcomp_eln_to_el_h); + return; } } } commit 886377fefd03a7b893afad28746e69615a300994 Merge: fc9b68636b f8d3d18168 Author: Andrea Corallo Date: Wed Aug 19 16:11:00 2020 +0200 Merge remote-tracking branch 'savannah/master' into HEAD commit fc9b68636b1aec69295726d2b3be2b520911f40b Author: Andrew Whatson Date: Tue Aug 18 11:29:22 2020 +0200 * Fix async compilation `comp-eln-load-path' effectiveness (bug#42909) * lisp/emacs-lisp/comp.el (comp-run-async-workers): Forward `comp-eln-load-path' to async workers. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 85b5562f28..3176351b37 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2580,6 +2580,7 @@ display a message." (setf comp-speed ,comp-speed comp-debug ,comp-debug comp-verbose ,comp-verbose + comp-eln-load-path ',comp-eln-load-path load-path ',load-path) ,comp-async-env-modifier-form (message "Compiling %s..." ,source-file) commit 76faab27cf4055f6ac37b9b05c98bc03939afb7e Author: Andrea Corallo Date: Mon Aug 17 11:54:55 2020 +0200 * Improve eln filename hashing Make eln filename hashing logic insensitive to the installation process. * src/comp.c (epaths.h): New include to have PATH_DUMPLOADSEARCH, PATH_LOADSEARCH definitions. (loadsearch_re_list): New static var. (Fcomp_el_to_eln_filename): Update logic to have the eln hashing insensitive to the installation process. (syms_of_comp): GC protect 'loadsearch_re_list'. diff --git a/src/comp.c b/src/comp.c index f4111e2a29..ff73245b8d 100644 --- a/src/comp.c +++ b/src/comp.c @@ -29,6 +29,7 @@ along with GNU Emacs. If not, see . */ #include #include #include +#include #include "puresize.h" #include "window.h" @@ -3860,29 +3861,68 @@ compile_function (Lisp_Object func) /* Entry points exposed to lisp. */ /**********************************/ +/* In use by Fcomp_el_to_eln_filename. */ +static Lisp_Object loadsearch_re_list; + DEFUN ("comp-el-to-eln-filename", Fcomp_el_to_eln_filename, Scomp_el_to_eln_filename, 1, 2, 0, doc: /* Given a source file return the corresponding .eln true filename. If BASE-DIR is nil use the first entry in `comp-eln-load-path'. */) - (Lisp_Object file_name, Lisp_Object base_dir) + (Lisp_Object filename, Lisp_Object base_dir) { - CHECK_STRING (file_name); - if (suffix_p (file_name, ".gz")) - file_name = Fsubstring (file_name, Qnil, make_fixnum (-3)); - file_name = Fexpand_file_name (file_name, Qnil); - Lisp_Object hashed = Fsubstring (comp_hash_string (file_name), Qnil, - make_fixnum (ELN_FILENAME_HASH_LEN)); - file_name = concat2 (Ffile_name_nondirectory (Fsubstring (file_name, Qnil, + CHECK_STRING (filename); + + if (suffix_p (filename, ".gz")) + filename = Fsubstring (filename, Qnil, make_fixnum (-3)); + filename = Fexpand_file_name (filename, Qnil); + + /* We create eln filenames with an hash in order to look-up these + starting from the source filename, IOW have a relation + /absolute/path/filename.el -> eln-cache/filename-hash.eln. + + As installing .eln files compiled during the build changes their + absolute path we need an hashing mechanism that is not sensitive + to that. For this we replace if match PATH_DUMPLOADSEARCH or + PATH_LOADSEARCH with '//' before generating the hash. + + Another approach would be to hash using the source file content + but this may have a measurable performance impact. */ + + if (NILP (loadsearch_re_list)) + { + Lisp_Object loadsearch_list = + Fcons (build_string (PATH_DUMPLOADSEARCH), + Fcons (build_string (PATH_LOADSEARCH), Qnil)); + FOR_EACH_TAIL (loadsearch_list) + loadsearch_re_list = + Fcons (Fregexp_quote (XCAR (loadsearch_list)), loadsearch_re_list); + } + Lisp_Object loadsearch_res = loadsearch_re_list; + FOR_EACH_TAIL (loadsearch_res) + { + Lisp_Object match_idx = + Fstring_match (XCAR (loadsearch_res), filename, Qnil); + if (EQ (match_idx, make_fixnum (0))) + { + filename = + Freplace_match (build_string ("//"), Qt, Qt, filename, Qnil); + break; + } + } + + Lisp_Object hash = Fsubstring (comp_hash_string (filename), Qnil, + make_fixnum (ELN_FILENAME_HASH_LEN)); + filename = concat2 (Ffile_name_nondirectory (Fsubstring (filename, Qnil, make_fixnum (-3))), build_string ("-")); - file_name = concat3 (file_name, hashed, build_string (NATIVE_ELISP_SUFFIX)); + filename = concat3 (filename, hash, build_string (NATIVE_ELISP_SUFFIX)); if (NILP (base_dir)) base_dir = XCAR (Vcomp_eln_load_path); if (!file_name_absolute_p (SSDATA (base_dir))) base_dir = Fexpand_file_name (base_dir, Vinvocation_directory); - return Fexpand_file_name (file_name, + return Fexpand_file_name (filename, concat2 (base_dir, Vcomp_native_path_postfix)); } @@ -5055,6 +5095,8 @@ native compiled one. */); comp.emitter_dispatcher = Qnil; staticpro (&delayed_sources); delayed_sources = Qnil; + staticpro (&loadsearch_re_list); + loadsearch_re_list = Qnil; #ifdef WINDOWSNT staticpro (&all_loaded_comp_units_h); commit 114b1d8f905edfeb7bd81b6a69c707336c01cde0 Author: Andrea Corallo Date: Sun Aug 16 20:44:56 2020 +0200 * test/src/comp-tests.el (comp-tests-bootstrap): Fix test for new eln setup. diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 092504565a..33b307b1c6 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -54,7 +54,8 @@ Check that the resulting binaries do not differ." (comp-debug 0)) (copy-file comp-src comp1-src t) (copy-file comp-src comp2-src t) - (load (concat comp-src "c") nil nil t t) + (let ((load-no-native t)) + (load (concat comp-src "c") nil nil t t)) (should-not (subr-native-elisp-p (symbol-function #'native-compile))) (message "Compiling stage1...") (let ((comp1-eln (native-compile comp1-src))) commit 142cfe942f9263efd6adab5f51f2feab4740735f Author: Andrea Corallo Date: Sun Aug 16 20:40:44 2020 +0200 * Introduce `load-no-native' Given load loads automatically a .eln in place of a .elc we need a way to force the .elc load in the case we really want it. * src/lread.c (syms_of_lread): Define `load-no-native'. (maybe_swap_for_eln): Make use of. diff --git a/src/lread.c b/src/lread.c index c5bec0633d..521da4e1d8 100644 --- a/src/lread.c +++ b/src/lread.c @@ -1615,7 +1615,8 @@ maybe_swap_for_eln (Lisp_Object *filename, int *fd, struct timespec mtime) #ifdef HAVE_NATIVE_COMP struct stat eln_st; - if (!suffix_p (*filename, ".elc")) + if (load_no_native + || !suffix_p (*filename, ".elc")) return; /* Search eln in the eln-cache directories. */ @@ -5156,6 +5157,11 @@ Note that if you customize this, obviously it will not affect files that are loaded before your customizations are read! */); load_prefer_newer = 0; + DEFVAR_BOOL ("load-no-native", load_no_native, + doc: /* Do not try to load the a .eln file in place of + a .elc one. */); + load_no_native = false; + /* Vsource_directory was initialized in init_lread. */ DEFSYM (Qcurrent_load_list, "current-load-list"); commit 40de06390d2cb594434ae4326b659522501882e2 Author: Andrea Corallo Date: Sun Aug 16 16:40:03 2020 +0200 * Remove a false permission related error while native compiling * lisp/emacs-lisp/bytecomp.el (byte-compile-file): Do not crash if native compiling we have no permission to create the .elc file. We are not creating it. diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 20a481a8a1..507cfe76ff 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -2041,7 +2041,8 @@ The value is non-nil if there were no errors, nil if errors." (with-current-buffer output-buffer (goto-char (point-max)) (insert "\n") ; aaah, unix. - (if (file-writable-p target-file) + (if (or (file-writable-p target-file) + byte-native-compiling) ;; We must disable any code conversion here. (progn (let* ((coding-system-for-write 'no-conversion) @@ -2050,7 +2051,8 @@ The value is non-nil if there were no errors, nil if errors." ;; parallel bootstrap), it does not risk getting a ;; half-finished file. (Bug#4196) (tempfile - (make-temp-file (expand-file-name target-file))) + (make-temp-file (when (file-writable-p target-file) + (expand-file-name target-file)))) (default-modes (default-file-modes)) (temp-modes (logand default-modes #o600)) (desired-modes (logand default-modes #o666)) commit da54406077c5facd7187aa17c9b4f5f4ddf0e233 Author: Andrea Corallo Date: Sun Aug 16 14:33:25 2020 +0200 Allow for native compiling .el.gz files This is needed for installed instances compiled with NATIVE_FAST_BOOT * src/comp.c (maybe_defer_native_compilation): Search for .el.gz too as a source if the .el is not found. (Fcomp_el_to_eln_filename): Remove the .gz in case to generate the hash. * lisp/emacs-lisp/comp.el (comp-valid-source-re): New defconst. (comp-run-async-workers, native-compile-async): Make use of `comp-valid-source-re'. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index b5ab4ebdcc..85b5562f28 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -137,6 +137,9 @@ before compilation. Usable to modify the compiler environment." (defvar comp-dry-run nil "When non nil run everything but the C back-end.") +(defconst comp-valid-source-re (rx ".el" (? ".gz") eos) + "Regexp to match filename of valid input source files.") + (defconst comp-log-buffer-name "*Native-compile-Log*" "Name of the native-compiler log buffer.") @@ -2564,7 +2567,7 @@ display a message." (cl-loop for (source-file . load) = (pop comp-files-queue) while source-file - do (cl-assert (string-match-p (rx ".el" eos) source-file) nil + do (cl-assert (string-match-p comp-valid-source-re source-file) nil "`comp-files-queue' should be \".el\" files: %s" source-file) when (or comp-always-compile @@ -2724,8 +2727,8 @@ LOAD can be nil t or 'late." (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)))) + (directory-files-recursively path comp-valid-source-re) + (directory-files path t comp-valid-source-re))) (push file files))) ((file-exists-p path) (push path files)) (t (signal 'native-compiler-error diff --git a/src/comp.c b/src/comp.c index d42bb4f8eb..f4111e2a29 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3867,6 +3867,8 @@ If BASE-DIR is nil use the first entry in `comp-eln-load-path'. */) (Lisp_Object file_name, Lisp_Object base_dir) { CHECK_STRING (file_name); + if (suffix_p (file_name, ".gz")) + file_name = Fsubstring (file_name, Qnil, make_fixnum (-3)); file_name = Fexpand_file_name (file_name, Qnil); Lisp_Object hashed = Fsubstring (comp_hash_string (file_name), Qnil, make_fixnum (ELN_FILENAME_HASH_LEN)); @@ -4494,7 +4496,11 @@ maybe_defer_native_compilation (Lisp_Object function_name, concat2 (CALL1I (file-name-sans-extension, Vload_true_file_name), build_pure_c_string (".el")); if (NILP (Ffile_exists_p (src))) - return; + { + src = concat2 (src, build_pure_c_string (".gz")); + if (NILP (Ffile_exists_p (src))) + return; + } /* This is to have deferred compilaiton able to compile comp dependecies breaking circularity. */ commit 171db3110159d95803dea13c4ee7bca4a795747b Author: Andrea Corallo Date: Sun Aug 16 11:18:36 2020 +0200 Make install target functional for new eln-cache directory arrangement * src/comp.h (fixup_eln_load_path): New extern. * src/comp.c (fixup_eln_load_path): New function. * src/pdumper.c (dump_do_dump_relocation): Update to make use of 'fixup_eln_load_path'. * lisp/loadup.el: Update to store in the compilation unit the correct eln-cache installed path. Rename --lisp-dest -> --eln-dest and. * Makefile.in: Pass the eln destination directory to src/Makefile. Rename LISP_DESTDIR -> ELN_DESTDIR. (ELN_DESTDIR): Define. (install-eln): New target. (install): Add install-eln as prerequisite. * src/Makefile.in: Rename --lisp-dest -> --eln-dest and LISP_DESTDIR -> ELN_DESTDIR. diff --git a/Makefile.in b/Makefile.in index 253f7f7a54..a15850d55e 100644 --- a/Makefile.in +++ b/Makefile.in @@ -108,6 +108,8 @@ am__v_at_ = $(am__v_at_@AM_DEFAULT_V@) am__v_at_0 = @ am__v_at_1 = +HAVE_NATIVE_COMP = @HAVE_NATIVE_COMP@ + # ==================== Where To Install Things ==================== # Location to install Emacs.app under GNUstep / macOS. @@ -330,6 +332,8 @@ CONFIG_STATUS_FILES_IN = \ COPYDIR = ${srcdir}/etc ${srcdir}/lisp COPYDESTS = "$(DESTDIR)${etcdir}" "$(DESTDIR)${lispdir}" +ELN_DESTDIR = "$(DESTDIR)${libexecdir}/emacs/${version}/${configuration}/" + all: ${SUBDIR} info .PHONY: all ${SUBDIR} blessmail epaths-force epaths-force-w32 etc-emacsver @@ -422,7 +426,7 @@ dirstate = .git/logs/HEAD VCSWITNESS = $(if $(wildcard $(srcdir)/$(dirstate)),$$(srcdir)/../$(dirstate)) src: Makefile $(MAKE) -C $@ VCSWITNESS='$(VCSWITNESS)' BIN_DESTDIR='$(DESTDIR)${bindir}/' \ - LISP_DESTDIR='$(DESTDIR)${lispdir}/' all + ELN_DESTDIR='$(ELN_DESTDIR)' all blessmail: Makefile src $(MAKE) -C lib-src maybe-blessmail @@ -462,14 +466,14 @@ $(srcdir)/configure: $(srcdir)/configure.ac $(srcdir)/m4/*.m4 # ==================== Installation ==================== .PHONY: install install-arch-dep install-arch-indep install-etcdoc install-info -.PHONY: install-man install-etc install-strip install-$(NTDIR) +.PHONY: install-man install-etc install-strip install-$(NTDIR) install-eln .PHONY: uninstall uninstall-$(NTDIR) ## If we let lib-src do its own installation, that means we ## don't have to duplicate the list of utilities to install in ## this Makefile as well. -install: all install-arch-indep install-etcdoc install-arch-dep install-$(NTDIR) blessmail +install: all install-arch-indep install-etcdoc install-arch-dep install-$(NTDIR) blessmail install-eln @true ## Ensure that $subdir contains a subdirs.el file. @@ -753,6 +757,12 @@ install-etc: done ; \ done +### Install native compiled Lisp files. +install-eln: +ifeq ($(HAVE_NATIVE_COMP),yes) + find eln-cache -type f -exec ${INSTALL_DATA} -D "{}" "$(ELN_DESTDIR){}" \; +endif + ### Build Emacs and install it, stripping binaries while installing them. install-strip: $(MAKE) INSTALL_STRIP=-s install diff --git a/lisp/loadup.el b/lisp/loadup.el index 31843fc24d..aaa5888bf9 100644 --- a/lisp/loadup.el +++ b/lisp/loadup.el @@ -449,33 +449,33 @@ lost after dumping"))) ;; At this point, we're ready to resume undo recording for scratch. (buffer-enable-undo "*scratch*") -(when (native-comp-available-p) +(when (boundp 'comp-ctxt) ;; Fix the compilation unit filename to have it working when ;; when installed or if the source directory got moved. This is set to be ;; a pair in the form: (rel-path-from-install-bin . rel-path-from-local-bin). (let ((h (make-hash-table :test #'eq)) - (lisp-src-dir (expand-file-name (concat default-directory "../lisp"))) (bin-dest-dir (cadr (member "--bin-dest" command-line-args))) - (lisp-dest-dir (cadr (member "--lisp-dest" command-line-args)))) - (mapatoms (lambda (s) - (let ((f (symbol-function s))) - (when (subr-native-elisp-p f) - (puthash (subr-native-comp-unit f) nil h))))) - (maphash (lambda (cu _) - (native-comp-unit-set-file - cu - (cons - ;; Relative path from the installed binary. - (file-relative-name - (concat lisp-dest-dir - (replace-regexp-in-string - (regexp-quote lisp-src-dir) "" - (native-comp-unit-file cu))) - bin-dest-dir) - ;; Relative path from the built uninstalled binary. - (file-relative-name (native-comp-unit-file cu) - invocation-directory)))) - h))) + (eln-dest-dir (cadr (member "--eln-dest" command-line-args)))) + (when (and bin-dest-dir eln-dest-dir) + (setq eln-dest-dir + (concat eln-dest-dir "eln-cache/" comp-native-path-postfix "/")) + (mapatoms (lambda (s) + (let ((f (symbol-function s))) + (when (subr-native-elisp-p f) + (puthash (subr-native-comp-unit f) nil h))))) + (maphash (lambda (cu _) + (native-comp-unit-set-file + cu + (cons + ;; Relative path from the installed binary. + (file-relative-name (concat eln-dest-dir + (file-name-nondirectory + (native-comp-unit-file cu))) + bin-dest-dir) + ;; Relative path from the built uninstalled binary. + (file-relative-name (native-comp-unit-file cu) + invocation-directory)))) + h)))) (when (hash-table-p purify-flag) (let ((strings 0) diff --git a/src/Makefile.in b/src/Makefile.in index 7380a87644..31a5a7e770 100644 --- a/src/Makefile.in +++ b/src/Makefile.in @@ -587,7 +587,7 @@ endif ifeq ($(DUMPING),pdumper) $(pdmp): emacs$(EXEEXT) LC_ALL=C $(RUN_TEMACS) -batch $(BUILD_DETAILS) -l loadup --temacs=pdump \ - --bin-dest $(BIN_DESTDIR) --lisp-dest $(LISP_DESTDIR) + --bin-dest $(BIN_DESTDIR) --eln-dest $(ELN_DESTDIR) cp -f $@ $(bootstrap_pdmp) endif diff --git a/src/comp.c b/src/comp.c index b795afae35..d42bb4f8eb 100644 --- a/src/comp.c +++ b/src/comp.c @@ -4529,6 +4529,27 @@ maybe_defer_native_compilation (Lisp_Object function_name, /* Functions used to load eln files. */ /**************************************/ +/* Fixup the system eln-cache dir. This is the last entry in + `comp-eln-load-path'. */ +void +fixup_eln_load_path (Lisp_Object directory) +{ + Lisp_Object last_cell = Qnil; + Lisp_Object tmp = Vcomp_eln_load_path; + FOR_EACH_TAIL (tmp) + if (CONSP (tmp)) + last_cell = tmp; + + Lisp_Object eln_cache_sys = + Ffile_name_directory (concat2 (Vinvocation_directory, + directory)); + /* One directory up... */ + eln_cache_sys = + Ffile_name_directory (Fsubstring (eln_cache_sys, Qnil, + make_fixnum (-1))); + Fsetcar (last_cell, eln_cache_sys); +} + typedef char *(*comp_lit_str_func) (void); /* Deserialize read and return static object. */ diff --git a/src/comp.h b/src/comp.h index 687e426b1e..9270f8bf66 100644 --- a/src/comp.h +++ b/src/comp.h @@ -101,6 +101,8 @@ extern void dispose_all_remaining_comp_units (void); extern void clean_package_user_dir_of_old_comp_units (void); +extern void fixup_eln_load_path (Lisp_Object directory); + #else /* #ifdef HAVE_NATIVE_COMP */ static inline void diff --git a/src/pdumper.c b/src/pdumper.c index ca055a1327..8172389a49 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -5249,23 +5249,12 @@ dump_do_dump_relocation (const uintptr_t dump_base, { fclose (file); installation_state = INSTALLED; - /* FIXME Vcomp_eln_load_path = ?? */ + fixup_eln_load_path (XCAR (comp_u->file)); } else { installation_state = LOCAL_BUILD; - /* Fixup `comp-eln-load-path' so emacs can be invoked - position independently. */ - Lisp_Object eln_cache_sys = - Ffile_name_directory (concat2 (Vinvocation_directory, - XCDR (comp_u->file))); - /* One directory up... */ - eln_cache_sys = - Ffile_name_directory (Fsubstring (eln_cache_sys, Qnil, - make_fixnum (-1))); - /* FIXME for subsequent dumps we should fixup only the - last entry. */ - Vcomp_eln_load_path = Fcons (eln_cache_sys, Qnil); + fixup_eln_load_path (XCDR (comp_u->file)); } } commit b6238d826e5abd1f49144df711deac6bffa3fe32 Author: Andrea Corallo Date: Sat Aug 15 20:12:46 2020 +0200 * Deferred compilation must always compile despite source file timestamp * lisp/emacs-lisp/comp.el (comp-run-async-workers): Always compile if load is set. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 802466550d..b5ab4ebdcc 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2568,6 +2568,8 @@ display a message." "`comp-files-queue' should be \".el\" files: %s" source-file) when (or comp-always-compile + load ; Always compile when the compilation is + ; commanded for late load. (file-newer-than-file-p source-file (comp-el-to-eln-filename source-file))) do (let* ((expr `(progn commit 377ffdb528e75f7e02be5f0305cdf326da0dc451 Author: Andrea Corallo Date: Sat Aug 15 11:29:06 2020 +0200 * Do not fail if more then one level of directories has to be created * lisp/emacs-lisp/comp.el (native-compile-async): Call make-directory if necessary. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 99bf30a4ee..802466550d 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2748,9 +2748,9 @@ queued with LOAD %" comp-deferred-compilation-black-list))) (let* ((out-filename (comp-el-to-eln-filename file)) (out-dir (file-name-directory out-filename))) - (if (or (file-writable-p out-filename) - (and (not (file-exists-p out-dir)) - (file-writable-p (substring out-dir 0 -1)))) + (unless (file-exists-p out-dir) + (make-directory out-dir t)) + (if (file-writable-p out-filename) (setf comp-files-queue (append comp-files-queue `((,file . ,load)))) (display-warning 'comp commit df774c4947c19478769587d587d07014aac79548 Author: Andrea Corallo Date: Sat Aug 15 10:54:22 2020 +0200 * Prevent recursive load Prevent autoload to kicks in while running `native-compile-async'. Autoload cannot be used safely by functions serving deferred compilation as a circular load can be triggered if the dependency is not native compiled already. * lisp/emacs-lisp/comp.el (warnings): Add require. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 5805e5c96a..99bf30a4ee 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -36,6 +36,7 @@ (require 'gv) (require 'rx) (require 'subr-x) +(require 'warnings) (defgroup comp nil "Emacs Lisp native compiler." commit dbeafd34032797c5d743a741492a5d9b35dd8c7b Author: Andrea Corallo Date: Fri Aug 14 09:05:31 2020 +0200 Some Makefile updates and clean-up * Makefile.in (clean): Remove 'eln-cache' folder. * lisp/Makefile.in (.SUFFIXES): Remove .eln. (native-compile-clean): Target remove. (compile-always, bootstrap-clean): Remove 'native-compile-clean' prerequisite. * src/Makefile.in (%.eln): Remove rule. diff --git a/Makefile.in b/Makefile.in index f28623ef56..253f7f7a54 100644 --- a/Makefile.in +++ b/Makefile.in @@ -863,6 +863,7 @@ clean: $(clean_dirs:=_clean) [ ! -d test ] || $(MAKE) -C test $@ -rm -f ./*.tmp etc/*.tmp* -rm -rf info-dir.* + -rm -rf eln-cache ### 'bootclean' ### Delete all files that need to be remade for a clean bootstrap. diff --git a/lisp/Makefile.in b/lisp/Makefile.in index 9bcceceb0e..164e4a01f5 100644 --- a/lisp/Makefile.in +++ b/lisp/Makefile.in @@ -302,7 +302,7 @@ endif # subdirectories, to make sure require's and load's in the files being # compiled find the right files. -.SUFFIXES: .eln .elc .el +.SUFFIXES: .elc .el # An old-fashioned suffix rule, which, according to the GNU Make manual, # cannot have prerequisites. @@ -357,13 +357,6 @@ compile-main: gen-lisp compile-clean TARGETS="$$chunk"; \ done -.PHONY: native-compile-clean -native-compile-clean: -# Erase all eln output compilation folders. -ifeq ($(HAVE_NATIVE_COMP),yes) - find $(lisp) -regex ".*/eln-.*-[0-9a-z]+\\'" -type d | xargs rm -rf -endif - .PHONY: compile-clean # Erase left-over .elc files that do not have a corresponding .el file. compile-clean: @@ -400,7 +393,7 @@ compile: $(LOADDEFS) autoloads compile-first # Compile all Lisp files. This is like 'compile' but compiles files # unconditionally. Some files don't actually get compiled because they # set the local variable no-byte-compile. -compile-always: native-compile-clean +compile-always: find $(lisp) -name '*.elc' $(FIND_DELETE) $(MAKE) compile @@ -490,7 +483,7 @@ $(CAL_DIR)/hol-loaddefs.el: $(CAL_SRC) $(CAL_DIR)/diary-loaddefs.el .PHONY: bootstrap-clean distclean maintainer-clean extraclean -bootstrap-clean: native-compile-clean +bootstrap-clean: find $(lisp) -name '*.elc' $(FIND_DELETE) rm -f $(AUTOGENEL) diff --git a/src/Makefile.in b/src/Makefile.in index 63a4aa80e9..7380a87644 100644 --- a/src/Makefile.in +++ b/src/Makefile.in @@ -790,10 +790,6 @@ tags: TAGS ../lisp/TAGS $(lwlibdir)/TAGS @$(MAKE) $(AM_V_NO_PD) -C ../lisp EMACS="$(bootstrap_exe)"\ THEFILE=$< $ Date: Thu Aug 13 23:47:54 2020 +0200 Make comp-deferred-compilation a simple global and set it on by default * src/comp.c (comp_deferred_compilation): Doc update and set it to true by default. * lisp/emacs-lisp/comp.el (comp-deferred-compilation): Remove customize. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 30cedf298e..5805e5c96a 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -41,13 +41,6 @@ "Emacs Lisp native compiler." :group 'lisp) -(defcustom comp-deferred-compilation nil - "If non-nil compile asyncronously all .elc files being loaded. -Once compilation happened each function definition is updated to -the native compiled one." - :type 'boolean - :group 'comp) - (defcustom comp-speed 2 "Compiler optimization level. From -1 to 3. - -1 functions are kept in bytecode form and no native compilation is performed. diff --git a/src/comp.c b/src/comp.c index 9582506f91..b795afae35 100644 --- a/src/comp.c +++ b/src/comp.c @@ -4901,7 +4901,13 @@ syms_of_comp (void) #ifdef HAVE_NATIVE_COMP /* Compiler control customizes. */ DEFVAR_BOOL ("comp-deferred-compilation", comp_deferred_compilation, - doc: /* If t compile asyncronously every .elc file loaded. */); + doc: /* If non-nil compile asyncronously all .elc files +being loaded. + +Once compilation happened each function definition is updated to the +native compiled one. */); + comp_deferred_compilation = true; + DEFSYM (Qcomp_speed, "comp-speed"); DEFSYM (Qcomp_debug, "comp-debug"); commit 3224a443060a5f21bb910064fc06fe4432810355 Author: Andrea Corallo Date: Sun Jul 19 10:46:24 2020 +0200 Move eln files into dedicated cache directories When loading a elc file search for a corresponding eln one into `comp-eln-load-path' directories and load it if available. `comp-eln-load-path' contains by default two directory (user and system one). * src/pdumper.c (dump_do_dump_relocation): While resurrecting from load set eln cache sys dir in `Vcomp_eln_load_path'. * src/lread.c (maybe_swap_for_eln): New function. (Fload): Clean-up some now unnecessary code going back to the master one. (Fload): Make use of Vcomp_eln_to_el_h for the reverse file look-up. (openp_add_middle_dir_to_suffixes) (openp_max_middledir_and_suffix_len, openp_fill_filename_buffer): Remove functions. (openp): As for Fload revert code modifications. (openp): When a .elc file is being loaded check if a corresponding eln can be loaded in place. * src/comp.c (ELN_FILENAME_HASH_LEN): New macro. (comp_hash_string): New function. (hash_native_abi): Make use of 'comp_hash_string'. (hash_native_abi): Change `comp-native-path-postfix' format. (Fcomp_el_to_eln_filename): New function. (Fcomp__compile_ctxt_to_file): Have file_name as a input. (Vcomp_eln_to_el_h, Vcomp_eln_load_path): New global varaibles. * lisp/startup.el (normal-top-level): Add user eln cache directory in `comp-eln-load-path'. * lisp/help-fns.el (find-lisp-object-file-name): Reverse look-up files using `comp-eln-to-el-h'. * lisp/files.el (locate-file): Likewise. * lisp/emacs-lisp/find-func.el (find-library-name): Likewise. * lisp/emacs-lisp/comp.el (comp-output-directory) (comp-output-base-filename, comp-output-filename): Remove function. (comp-compile-ctxt-to-file): Create parent directories if necessary. (comp-run-async-workers, native-compile, native-compile-async): Make use `comp-el-to-eln-filename'. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index a92392f63a..30cedf298e 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -569,28 +569,6 @@ VERBOSITY is a number between 0 and 3." -(defun comp-output-directory (src) - "Return the compilation direcotry for source SRC." - (let* ((src (if (symbolp src) (symbol-name src) src)) - (expanded-filename (expand-file-name src))) - (file-name-as-directory - (concat (file-name-directory expanded-filename) - comp-native-path-postfix)))) - -(defun comp-output-base-filename (src) - "Output filename sans extention for SRC file being native compiled." - (let* ((src (if (symbolp src) (symbol-name src) src)) - (expanded-filename (expand-file-name src)) - (output-dir (comp-output-directory src)) - (output-filename - (file-name-sans-extension - (file-name-nondirectory expanded-filename)))) - (expand-file-name output-filename output-dir))) - -(defun comp-output-filename (src) - "Output filename for SRC file being native compiled." - (concat (comp-output-base-filename src) ".eln")) - (defmacro comp-loop-insn-in-block (basic-block &rest body) "Loop over all insns in BASIC-BLOCK executning BODY. Inside BODY `insn' can be used to read or set the current @@ -2486,7 +2464,7 @@ Prepare every function for final compilation and drive the C back-end." (unless (file-exists-p dir) ;; In case it's created in the meanwhile. (ignore-error 'file-already-exists - (make-directory dir))) + (make-directory dir t))) (unless comp-dry-run (comp--compile-ctxt-to-file name)))) @@ -2597,7 +2575,7 @@ display a message." source-file) when (or comp-always-compile (file-newer-than-file-p source-file - (comp-output-filename source-file))) + (comp-el-to-eln-filename source-file))) do (let* ((expr `(progn (require 'comp) (setf comp-speed ,comp-speed @@ -2636,7 +2614,7 @@ display a message." (when (and load1 (zerop (process-exit-status process))) (native-elisp-load - (comp-output-filename source-file1) + (comp-el-to-eln-filename source-file1) (eq load1 'late))) (comp-run-async-workers))))) (puthash source-file process comp-async-compilations)) @@ -2676,7 +2654,11 @@ Return the compilation unit file name." (byte-compile-debug t) (comp-ctxt (make-comp-ctxt - :output (comp-output-base-filename function-or-file) + :output (comp-el-to-eln-filename (if (symbolp function-or-file) + (symbol-name function-or-file) + function-or-file) + (when byte-native-for-bootstrap + (car (last comp-eln-load-path)))) :with-late-load with-late-load))) (comp-log "\n \n" 1) (condition-case err @@ -2770,8 +2752,8 @@ queued with LOAD %" (and (eq load 'late) (cl-some (lambda (re) (string-match re file)) comp-deferred-compilation-black-list))) - (let ((out-dir (comp-output-directory file)) - (out-filename (comp-output-filename file))) + (let* ((out-filename (comp-el-to-eln-filename file)) + (out-dir (file-name-directory out-filename))) (if (or (file-writable-p out-filename) (and (not (file-exists-p out-dir)) (file-writable-p (substring out-dir 0 -1)))) diff --git a/lisp/emacs-lisp/find-func.el b/lisp/emacs-lisp/find-func.el index efbcfb3a72..2db976f8c5 100644 --- a/lisp/emacs-lisp/find-func.el +++ b/lisp/emacs-lisp/find-func.el @@ -188,11 +188,7 @@ LIBRARY should be a string (the name of the library)." ((string-match "\\.el\\(c\\(\\..*\\)?\\)\\'" library) (setq library (replace-match "" t t library))) ((string-match "\\.eln\\'" library) - ;; From help-fns.el. - (setq library (expand-file-name (concat (file-name-base library) - ".el") - (concat (file-name-directory library) - ".."))))) + (setq library (gethash (file-name-nondirectory library) comp-eln-to-el-h)))) (or (locate-file library (or find-function-source-path load-path) diff --git a/lisp/files.el b/lisp/files.el index 9270f334af..2aeae0a9be 100644 --- a/lisp/files.el +++ b/lisp/files.el @@ -926,7 +926,10 @@ one or more of those symbols." (logior (if (memq 'executable predicate) 1 0) (if (memq 'writable predicate) 2 0) (if (memq 'readable predicate) 4 0)))) - (locate-file-internal filename path suffixes predicate)) + (let ((file (locate-file-internal filename path suffixes predicate))) + (if (and file (string-match "\\.eln\\'" file)) + (gethash (file-name-nondirectory file) comp-eln-to-el-h) + file))) (defun locate-file-completion-table (dirs suffixes string pred action) "Do completion for file names passed to `locate-file'." diff --git a/lisp/help-fns.el b/lisp/help-fns.el index afca2cd932..49cdb4ed5e 100644 --- a/lisp/help-fns.el +++ b/lisp/help-fns.el @@ -333,10 +333,8 @@ suitable file is found, return nil." object (or (if (symbolp type) type) 'defun)))) (file-name (if (and true-name (string-match "[.]eln\\'" true-name)) - (expand-file-name (concat (file-name-base true-name) - ".el") - (concat (file-name-directory true-name) - "..")) + (gethash (file-name-nondirectory true-name) + comp-eln-to-el-h) true-name))) (cond (autoloaded diff --git a/lisp/startup.el b/lisp/startup.el index e58f27e7eb..e469b90bd6 100644 --- a/lisp/startup.el +++ b/lisp/startup.el @@ -537,6 +537,9 @@ It is the default value of the variable `top-level'." (setq user-emacs-directory (startup--xdg-or-homedot startup--xdg-config-home-emacs nil)) + (when (boundp 'comp-eln-load-path) + (setq comp-eln-load-path (cons (concat user-emacs-directory "eln-cache/") + comp-eln-load-path))) ;; Look in each dir in load-path for a subdirs.el file. If we ;; find one, load it, which will add the appropriate subdirs of ;; that dir into load-path. This needs to be done before setting diff --git a/src/comp.c b/src/comp.c index 704bd4b6b3..9582506f91 100644 --- a/src/comp.c +++ b/src/comp.c @@ -393,6 +393,8 @@ load_gccjit_if_necessary (bool mandatory) } +#define ELN_FILENAME_HASH_LEN 64 + /* C symbols emitted for the load relocation mechanism. */ #define CURRENT_THREAD_RELOC_SYM "current_thread_reloc" #define PURE_RELOC_SYM "pure_reloc" @@ -634,6 +636,16 @@ format_string (const char *format, ...) return scratch_area; } +static Lisp_Object +comp_hash_string (Lisp_Object string) +{ + Lisp_Object digest = make_uninit_string (SHA512_DIGEST_SIZE * 2); + sha512_buffer (SSDATA (string), SCHARS (string), SSDATA (digest)); + hexbuf_digest (SSDATA (digest), SDATA (digest), SHA512_DIGEST_SIZE); + + return digest; +} + /* Produce a key hashing Vcomp_subr_list. */ void @@ -641,10 +653,7 @@ hash_native_abi (void) { Lisp_Object string = Fmapconcat (intern_c_string ("subr-name"), Vcomp_subr_list, build_string (" ")); - Lisp_Object digest = make_uninit_string (SHA512_DIGEST_SIZE * 2); - - sha512_buffer (SSDATA (string), SCHARS (string), SSDATA (digest)); - hexbuf_digest (SSDATA (digest), SDATA (digest), SHA512_DIGEST_SIZE); + Lisp_Object digest = comp_hash_string (string); /* Check runs once. */ eassert (NILP (Vcomp_abi_hash)); @@ -652,8 +661,7 @@ hash_native_abi (void) /* If 10 characters are usually sufficient for git I guess 16 are fine for us here. */ Vcomp_native_path_postfix = - concat3 (make_string ("eln-", 4), - Vsystem_configuration, + concat2 (Vsystem_configuration, concat2 (make_string ("-", 1), Fsubstring_no_properties (Vcomp_abi_hash, make_fixnum (0), @@ -3852,6 +3860,30 @@ compile_function (Lisp_Object func) /* Entry points exposed to lisp. */ /**********************************/ +DEFUN ("comp-el-to-eln-filename", Fcomp_el_to_eln_filename, + Scomp_el_to_eln_filename, 1, 2, 0, + doc: /* Given a source file return the corresponding .eln true filename. +If BASE-DIR is nil use the first entry in `comp-eln-load-path'. */) + (Lisp_Object file_name, Lisp_Object base_dir) +{ + CHECK_STRING (file_name); + file_name = Fexpand_file_name (file_name, Qnil); + Lisp_Object hashed = Fsubstring (comp_hash_string (file_name), Qnil, + make_fixnum (ELN_FILENAME_HASH_LEN)); + file_name = concat2 (Ffile_name_nondirectory (Fsubstring (file_name, Qnil, + make_fixnum (-3))), + build_string ("-")); + file_name = concat3 (file_name, hashed, build_string (NATIVE_ELISP_SUFFIX)); + if (NILP (base_dir)) + base_dir = XCAR (Vcomp_eln_load_path); + + if (!file_name_absolute_p (SSDATA (base_dir))) + base_dir = Fexpand_file_name (base_dir, Vinvocation_directory); + + return Fexpand_file_name (file_name, + concat2 (base_dir, Vcomp_native_path_postfix)); +} + DEFUN ("comp--init-ctxt", Fcomp__init_ctxt, Scomp__init_ctxt, 0, 0, 0, doc: /* Initialize the native compiler context. Return t on success. */) @@ -4039,11 +4071,12 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, Scomp__compile_ctxt_to_file, 1, 1, 0, doc: /* Compile as native code the current context to file. */) - (Lisp_Object base_name) + (Lisp_Object file_name) { load_gccjit_if_necessary (true); - CHECK_STRING (base_name); + CHECK_STRING (file_name); + Lisp_Object base_name = Fsubstring (file_name, Qnil, make_fixnum (-4)); gcc_jit_context_set_int_option (comp.ctxt, GCC_JIT_INT_OPTION_OPTIMIZATION_LEVEL, @@ -4105,19 +4138,18 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, AUTO_STRING (dot_so, NATIVE_ELISP_SUFFIX); - Lisp_Object out_file = CALLN (Fconcat, base_name, dot_so); Lisp_Object tmp_file = Fmake_temp_file_internal (base_name, Qnil, dot_so, Qnil); gcc_jit_context_compile_to_file (comp.ctxt, GCC_JIT_OUTPUT_KIND_DYNAMIC_LIBRARY, SSDATA (tmp_file)); - CALL2I (comp--replace-output-file, out_file, tmp_file); + CALL2I (comp--replace-output-file, file_name, tmp_file); if (!noninteractive) unbind_to (count, Qnil); - return out_file; + return file_name; } DEFUN ("comp-libgccjit-version", Fcomp_libgccjit_version, @@ -4971,6 +5003,7 @@ syms_of_comp (void) build_pure_c_string ("eln file inconsistent with current runtime " "configuration, please recompile")); + defsubr (&Scomp_el_to_eln_filename); defsubr (&Scomp__init_ctxt); defsubr (&Scomp__release_ctxt); defsubr (&Scomp__compile_ctxt_to_file); @@ -5015,6 +5048,22 @@ syms_of_comp (void) internal use during */); Vcomp_deferred_pending_h = CALLN (Fmake_hash_table, QCtest, Qeq); + DEFVAR_LISP ("comp-eln-to-el-h", Vcomp_eln_to_el_h, + doc: /* Hash table eln-filename -> el-filename. */); + Vcomp_eln_to_el_h = CALLN (Fmake_hash_table, QCtest, Qequal); + + DEFVAR_LISP ("comp-eln-load-path", Vcomp_eln_load_path, + doc: /* List of eln cache directories. + +If a directory is non absolute is assumed to be relative to +`invocation-directory'. +The last directory of this list is assumed to be the system one. */); + + /* Temporary value in use for boostrap. We can't do better as + `invocation-directory' is still unset, will be fixed up during + dump reload. */ + Vcomp_eln_load_path = Fcons (build_string ("../eln-cache/"), Qnil); + #endif /* #ifdef HAVE_NATIVE_COMP */ defsubr (&Snative_comp_available_p); diff --git a/src/lread.c b/src/lread.c index f10a20ded8..c5bec0633d 100644 --- a/src/lread.c +++ b/src/lread.c @@ -1231,8 +1231,7 @@ Return t if the file exists and loads successfully. */) suffixes = CALLN (Fappend, suffixes, Vload_file_rep_suffixes); } - fd = - openp (Vload_path, file, suffixes, &found, Qnil, load_prefer_newer); + fd = openp (Vload_path, file, suffixes, &found, Qnil, load_prefer_newer); } if (fd == -1) @@ -1478,9 +1477,8 @@ Return t if the file exists and loads successfully. */) same folder of their respective sources therfore not to break packages we fake `load-file-name' here. The non faked version of it is `load-true-file-name'. */ - specbind (Qload_file_name, - concat2 (parent_directory (Ffile_name_directory (found)), - Ffile_name_nondirectory (found))); + specbind (Qload_file_name, Fgethash (Ffile_name_nondirectory (found), + Vcomp_eln_to_el_h, Qnil)); } else specbind (Qload_file_name, found); @@ -1608,118 +1606,51 @@ directories, make sure the PREDICATE function returns `dir-ok' for them. */) return file; } -/* This function turns a list of suffixes into a list of middle dirs - and suffixes. If the suffix is not NATIVE_ELISP_SUFFIX then its - suffix is nil and it is added to the list as is. Instead, if it - suffix is NATIVE_ELISP_SUFFIX then two elements are added to the - list. The first one has middledir equal to nil and the second uses - comp-native-path-postfix as middledir. This is because we'd like - to search for dir/foo.eln before dir/middledir/foo.eln. +/* Look for a suitable .eln file to be loaded in place of FILENAME. + If found replace the content of FILENAME and FD. */ -For example, it turns this: - -(".eln" ".elc" ".elc.gz" ".el" ".el.gz") - - into this: - -((nil . ".eln") - (comp-native-path-postfix . ".eln") - (nil . ".elc") - (nil . ".elc.gz") - (nil . ".el") - (nil . ".el.gz")) -*/ -static Lisp_Object -openp_add_middle_dir_to_suffixes (Lisp_Object suffixes) +static void +maybe_swap_for_eln (Lisp_Object *filename, int *fd, struct timespec mtime) { - Lisp_Object tail = suffixes; - Lisp_Object extended_suf = Qnil; - FOR_EACH_TAIL_SAFE (tail) - { - /* suffixes may be a stack-based cons pointing to stack-based - strings. We must copy the suffix if we are putting it into - a heap-based cons to avoid a dangling reference. This would - lead to crashes during the GC. */ - CHECK_STRING_CAR (tail); - char * suf = SSDATA (XCAR (tail)); - Lisp_Object copied_suffix = build_string (suf); #ifdef HAVE_NATIVE_COMP - if (strcmp (NATIVE_ELISP_SUFFIX, suf) == 0) - { - CHECK_STRING (Vcomp_native_path_postfix); - /* Here we add them in the opposite order so that nreverse - corrects it. */ - extended_suf = Fcons (Fcons (Qnil, copied_suffix), extended_suf); - extended_suf = Fcons (Fcons (Vcomp_native_path_postfix, - copied_suffix), - extended_suf); - } - else -#endif - extended_suf = Fcons (Fcons (Qnil, copied_suffix), extended_suf); - } + struct stat eln_st; - suffixes = Fnreverse (extended_suf); - return suffixes; -} + if (!suffix_p (*filename, ".elc")) + return; -/* This function takes a list of middledirs and suffixes and returns - the maximum buffer space that this part of the filename will - need. */ -static ptrdiff_t -openp_max_middledir_and_suffix_len (Lisp_Object middledir_and_suffixes) -{ - ptrdiff_t max_extra_len = 0; - Lisp_Object tail = middledir_and_suffixes; - FOR_EACH_TAIL_SAFE (tail) + /* Search eln in the eln-cache directories. */ + Lisp_Object eln_path_tail = Vcomp_eln_load_path; + FOR_EACH_TAIL_SAFE (eln_path_tail) { - Lisp_Object middledir_and_suffix = XCAR (tail); - Lisp_Object middledir = XCAR (middledir_and_suffix); - Lisp_Object suffix = XCDR (middledir_and_suffix); - ptrdiff_t len = SBYTES (suffix); - if (!NILP (middledir)) - len += 2 + SBYTES (middledir); /* Add two slashes. */ - max_extra_len = max (max_extra_len, len); - } - return max_extra_len; -} + Lisp_Object el_name = + Fsubstring (*filename, Qnil, make_fixnum (-1)); + Lisp_Object eln_name = + Fcomp_el_to_eln_filename (el_name, XCAR (eln_path_tail)); + int eln_fd = emacs_open (SSDATA (ENCODE_FILE (eln_name)), O_RDONLY, 0); -/* This function completes the FN buffer with the middledir, - basenameme, and suffix. It takes the directory length in DIRNAME, - but it requires that it has been copied already to the start of - the buffer. - - After this function the FN buffer will be (depending on middledir) - dirname/middledir/basename.suffix - or - dirname/basename.suffix -*/ -static ptrdiff_t -openp_fill_filename_buffer (char *fn, ptrdiff_t dirnamelen, - Lisp_Object basenamewext, - Lisp_Object middledir_and_suffix) -{ - Lisp_Object middledir = XCAR (middledir_and_suffix); - Lisp_Object suffix = XCDR (middledir_and_suffix); - ptrdiff_t basenamewext_len = SBYTES (basenamewext); - ptrdiff_t fnlen, lsuffix = SBYTES (suffix); - ptrdiff_t lmiddledir = 0; - if (!NILP (middledir)) - { - /* Add 1 for the slash. */ - lmiddledir = SBYTES (middledir) + 1; - memcpy (fn + dirnamelen, SDATA (middledir), - lmiddledir - 1); - fn[dirnamelen + (lmiddledir - 1)] = '/'; + if (eln_fd > 0) + { + if (fstat (eln_fd, &eln_st) || S_ISDIR (eln_st.st_mode)) + emacs_close (eln_fd); + else + { + struct timespec eln_mtime = get_stat_mtime (&eln_st); + if (timespec_cmp (eln_mtime, mtime) > 0) + { + *filename = eln_name; + emacs_close (*fd); + *fd = eln_fd; + /* Store the eln -> el relation. */ + Fputhash (Ffile_name_nondirectory (eln_name), + el_name, Vcomp_eln_to_el_h); + return; + } + else + emacs_close (eln_fd); + } + } } - - memcpy (fn + dirnamelen + lmiddledir, SDATA (basenamewext), - basenamewext_len); - /* Make complete filename by appending SUFFIX. */ - memcpy (fn + dirnamelen + lmiddledir + basenamewext_len, - SDATA (suffix), lsuffix + 1); - fnlen = dirnamelen + lmiddledir + basenamewext_len + lsuffix; - return fnlen; +#endif } /* Search for a file whose name is STR, looking in directories @@ -1759,21 +1690,23 @@ openp (Lisp_Object path, Lisp_Object str, Lisp_Object suffixes, ptrdiff_t want_length; Lisp_Object filename; Lisp_Object string, tail, encoded_fn, save_string; - Lisp_Object middledir_and_suffixes; - ptrdiff_t max_extra_len = 0; + ptrdiff_t max_suffix_len = 0; int last_errno = ENOENT; int save_fd = -1; USE_SAFE_ALLOCA; - /* The last-modified time of the newest matching file found. Initialize it to something less than all valid timestamps. */ struct timespec save_mtime = make_timespec (TYPE_MINIMUM (time_t), -1); CHECK_STRING (str); - middledir_and_suffixes = openp_add_middle_dir_to_suffixes (suffixes); - - max_extra_len = openp_max_middledir_and_suffix_len (middledir_and_suffixes); + tail = suffixes; + FOR_EACH_TAIL_SAFE (tail) + { + CHECK_STRING_CAR (tail); + max_suffix_len = max (max_suffix_len, + SBYTES (XCAR (tail))); + } string = filename = encoded_fn = save_string = Qnil; @@ -1790,7 +1723,7 @@ openp (Lisp_Object path, Lisp_Object str, Lisp_Object suffixes, executable. */ FOR_EACH_TAIL_SAFE (path) { - ptrdiff_t dirnamelen, prefixlen; + ptrdiff_t baselen, prefixlen; if (EQ (path, just_use_str)) filename = str; @@ -1807,40 +1740,35 @@ openp (Lisp_Object path, Lisp_Object str, Lisp_Object suffixes, continue; } - /* Calculate maximum length of any filename made from this path element/specified file name and any possible suffix. */ - want_length = max_extra_len + SBYTES (filename); + want_length = max_suffix_len + SBYTES (filename); if (fn_size <= want_length) { fn_size = 100 + want_length; fn = SAFE_ALLOCA (fn_size); } - Lisp_Object dirnamewslash = Ffile_name_directory (filename); - Lisp_Object basenamewext = Ffile_name_nondirectory (filename); - /* Copy FILENAME's data to FN but remove starting /: if any. */ - prefixlen = ((SCHARS (dirnamewslash) > 2 - && SREF (dirnamewslash, 0) == '/' - && SREF (dirnamewslash, 1) == ':') + prefixlen = ((SCHARS (filename) > 2 + && SREF (filename, 0) == '/' + && SREF (filename, 1) == ':') ? 2 : 0); - dirnamelen = SBYTES (dirnamewslash) - prefixlen; - memcpy (fn, SDATA (dirnamewslash) + prefixlen, dirnamelen); + baselen = SBYTES (filename) - prefixlen; + memcpy (fn, SDATA (filename) + prefixlen, baselen); - /* Loop over middledir_and_suffixes. */ - AUTO_LIST1 (empty_string_only, Fcons (Qnil, empty_unibyte_string)); - tail = NILP (middledir_and_suffixes) ? empty_string_only - : middledir_and_suffixes; + /* Loop over suffixes. */ + AUTO_LIST1 (empty_string_only, empty_unibyte_string); + tail = NILP (suffixes) ? empty_string_only : suffixes; FOR_EACH_TAIL_SAFE (tail) { - Lisp_Object middledir_and_suffix = XCAR (tail); - Lisp_Object suffix = XCDR (middledir_and_suffix); + Lisp_Object suffix = XCAR (tail); + ptrdiff_t fnlen, lsuffix = SBYTES (suffix); Lisp_Object handler; - ptrdiff_t fnlen = openp_fill_filename_buffer (fn, dirnamelen, - basenamewext, - middledir_and_suffix); + /* Make complete filename by appending SUFFIX. */ + memcpy (fn + baselen, SDATA (suffix), lsuffix + 1); + fnlen = baselen + lsuffix; /* Check that the file exists and is not a directory. */ /* We used to only check for handlers on non-absolute file names: @@ -1962,9 +1890,11 @@ openp (Lisp_Object path, Lisp_Object str, Lisp_Object suffixes, } else { + maybe_swap_for_eln (&string, &fd, get_stat_mtime (&st)); /* We succeeded; return this descriptor and filename. */ if (storeptr) *storeptr = string; + SAFE_FREE (); return fd; } @@ -1973,6 +1903,7 @@ openp (Lisp_Object path, Lisp_Object str, Lisp_Object suffixes, /* No more suffixes. Return the newest. */ if (0 <= save_fd && ! CONSP (XCDR (tail))) { + maybe_swap_for_eln (&save_string, &save_fd, save_mtime); if (storeptr) *storeptr = save_string; SAFE_FREE (); @@ -5030,11 +4961,8 @@ to the specified file name if a suffix is allowed or required. */); Vload_suffixes = Fcons (build_pure_c_string (MODULES_SECONDARY_SUFFIX), Vload_suffixes); #endif -#endif -#ifdef HAVE_NATIVE_COMP - Vload_suffixes = Fcons (build_pure_c_string (NATIVE_ELISP_SUFFIX), Vload_suffixes); -#endif +#endif DEFVAR_LISP ("module-file-suffix", Vmodule_file_suffix, doc: /* Suffix of loadable module file, or nil if modules are not supported. */); #ifdef HAVE_MODULES diff --git a/src/pdumper.c b/src/pdumper.c index 629d096934..ca055a1327 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -5249,9 +5249,24 @@ dump_do_dump_relocation (const uintptr_t dump_base, { fclose (file); installation_state = INSTALLED; + /* FIXME Vcomp_eln_load_path = ?? */ } else - installation_state = LOCAL_BUILD; + { + installation_state = LOCAL_BUILD; + /* Fixup `comp-eln-load-path' so emacs can be invoked + position independently. */ + Lisp_Object eln_cache_sys = + Ffile_name_directory (concat2 (Vinvocation_directory, + XCDR (comp_u->file))); + /* One directory up... */ + eln_cache_sys = + Ffile_name_directory (Fsubstring (eln_cache_sys, Qnil, + make_fixnum (-1))); + /* FIXME for subsequent dumps we should fixup only the + last entry. */ + Vcomp_eln_load_path = Fcons (eln_cache_sys, Qnil); + } } comp_u->file = commit f2e6168ece69d635b4f9d9a138100c6772903d0b Author: Andrea Corallo Date: Sat Aug 15 20:22:10 2020 +0200 * Remove a warning for conventional build * src/lread.c (parent_directory): Add ATTRIBUTE_UNUSED. diff --git a/src/lread.c b/src/lread.c index f5a7d44a1e..f10a20ded8 100644 --- a/src/lread.c +++ b/src/lread.c @@ -1099,7 +1099,7 @@ close_infile_unwind (void *arg) infile = prev_infile; } -static Lisp_Object +static ATTRIBUTE_UNUSED Lisp_Object parent_directory (Lisp_Object directory) { return Ffile_name_directory (Fsubstring (directory, commit 3882e8fd244a66edb6ba60f40182a4d0772cfcb1 Author: Andrea Corallo Date: Fri Aug 14 08:29:28 2020 +0200 * Fix excessive echo area usage * lisp/emacs-lisp/comp.el (comp-run-async-workers): Use `with-temp-file' to fill temp-file. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 599d35b61c..a92392f63a 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2608,13 +2608,16 @@ display a message." (message "Compiling %s..." ,source-file) (native-compile ,source-file ,(and load t)))) (source-file1 source-file) ;; Make the closure works :/ - (_ (progn - (comp-log "\n") - (comp-log (prin1-to-string expr)))) (temp-file (make-temp-file (concat "emacs-async-comp-" (file-name-base source-file) "-") - nil ".el" (prin1-to-string expr))) + nil ".el")) + (expr-string (prin1-to-string expr)) + (_ (progn + (with-temp-file temp-file + (insert expr-string)) + (comp-log "\n") + (comp-log expr-string))) (load1 load) (process (make-process :name (concat "Compiling: " source-file) commit 1712311f0084af850925f4c472f6ca186ab09c54 Author: Andrea Corallo Date: Thu Aug 13 17:13:11 2020 +0200 * src/pdumper.c (dump_do_dump_relocation): Improve error messages. diff --git a/src/pdumper.c b/src/pdumper.c index 83410e3677..629d096934 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -5281,12 +5281,13 @@ dump_do_dump_relocation (const uintptr_t dump_base, struct Lisp_Native_Comp_Unit *comp_u = XNATIVE_COMP_UNIT (subr->native_comp_u[0]); if (!comp_u->handle) - error ("can't relocate native subr with not loaded compilation unit"); + error ("NULL handle in compilation unit %s", SSDATA (comp_u->file)); const char *c_name = subr->native_c_name[0]; eassert (c_name); void *func = dynlib_sym (comp_u->handle, c_name); if (!func) - error ("can't find function in compilation unit"); + error ("can't find function \"%s\" in compilation unit %s", c_name, + SSDATA (comp_u->file)); subr->function.a0 = func; Lisp_Object lambda_data_idx = Fgethash (build_string (c_name), comp_u->lambda_c_name_idx_h, Qnil); commit b85870e65b642d4a38d797bfe7bcab7b7f9c15f0 Author: Andrea Corallo Date: Thu Aug 13 12:47:34 2020 +0200 * src/pdumper.c (dump_cold_native_subr): Clean-up *IMPLICIT_CONVERSION macros. diff --git a/src/pdumper.c b/src/pdumper.c index c55b6f7bb4..83410e3677 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -3416,18 +3416,14 @@ dump_cold_native_subr (struct dump_context *ctx, Lisp_Object subr) subr_offset + dump_offsetof (struct Lisp_Subr, symbol_name), ctx->offset); const char *symbol_name = XSUBR (subr)->symbol_name; - ALLOW_IMPLICIT_CONVERSION; dump_write (ctx, symbol_name, 1 + strlen (symbol_name)); - DISALLOW_IMPLICIT_CONVERSION; dump_remember_fixup_ptr_raw (ctx, subr_offset + dump_offsetof (struct Lisp_Subr, native_c_name[0]), ctx->offset); const char *c_name = XSUBR (subr)->native_c_name[0]; - ALLOW_IMPLICIT_CONVERSION; dump_write (ctx, c_name, 1 + strlen (c_name)); - DISALLOW_IMPLICIT_CONVERSION; } static void commit 46e7613ad3b88807d25cfab3d78bf46c9e2fe13e Merge: f6502f9592 e9eafd2268 Author: Andrea Corallo Date: Thu Aug 13 12:22:07 2020 +0200 Merge remote-tracking branch 'savannah/master' into HEAD commit f6502f959253b8f705e324e137c2933c5a668f62 Author: Andrea Corallo Date: Thu Aug 13 09:45:16 2020 +0200 ; * lisp/emacs-lisp/comp.el (comp-deferred-compilation): Fix doc. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index c5027168be..599d35b61c 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -42,7 +42,7 @@ :group 'lisp) (defcustom comp-deferred-compilation nil - "If t compile asyncronously all lexically bound .elc files being loaded. + "If non-nil compile asyncronously all .elc files being loaded. Once compilation happened each function definition is updated to the native compiled one." :type 'boolean commit dd814b0a58aebe12168ffde946860e851ecf2b5b Author: Andrea Corallo Date: Wed Aug 5 08:47:56 2020 +0200 * lisp/emacs-lisp/bytecomp.el: Guard against double native compilation. diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index c5b086f91a..20a481a8a1 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -5269,9 +5269,10 @@ and corresponding effects." (let ((byte-optimize nil) ; do it fast (byte-compile-warnings nil)) (mapc (lambda (x) - (or noninteractive (message "compiling %s..." x)) - (byte-compile x) - (or noninteractive (message "compiling %s...done" x))) + (unless (subr-native-elisp-p x) + (or noninteractive (message "compiling %s..." x)) + (byte-compile x) + (or noninteractive (message "compiling %s...done" x)))) '(byte-compile-normal-call byte-compile-form byte-compile-body commit 12a982d9789052d8e85efcacb4b311f4876c882a Merge: 80d7f710f2 8e82baf5a7 Author: Andrea Corallo Date: Sun Aug 9 15:03:23 2020 +0200 Merge remote-tracking branch 'savannah/master' into HEAD commit 80d7f710f2fab902e46aa3fddb8e1c1795420af3 Author: Andrea Corallo Date: Sun Aug 2 17:01:42 2020 +0200 * Fix defsubst missing inline Bug#42664 * lisp/emacs-lisp/byte-run.el (defsubst): Do not native compile defsubsts to have them always effective. diff --git a/lisp/emacs-lisp/byte-run.el b/lisp/emacs-lisp/byte-run.el index 4c1dce264a..539846683f 100644 --- a/lisp/emacs-lisp/byte-run.el +++ b/lisp/emacs-lisp/byte-run.el @@ -364,7 +364,12 @@ You don't need this. (See bytecomp.el commentary for more details.) '(nil byte-compile-inline-expand)) (error "`%s' is a primitive" name)) `(prog1 - (defun ,name ,arglist ,@body) + (defun ,name ,arglist + ;; Never native-compile defsubsts as we need the byte + ;; definition in `byte-compile-unfold-bcf' to perform the + ;; inlining (Bug#42664). + (declare (speed -1)) + ,@body) (eval-and-compile (put ',name 'byte-optimizer 'byte-compile-inline-expand)))) commit e5095f0fd31764a729b4afebf8b5e868a09eef28 Merge: 7a161dc688 99d1a66646 Author: Andrea Corallo Date: Sun Aug 2 17:36:29 2020 +0200 Merge remote-tracking branch 'savannah/master' into HEAD commit 7a161dc688f0eeee64e307a55efbc7d11bab3627 Merge: 79ed903805 9f01ce6327 Author: Andrea Corallo Date: Sun Jul 26 09:40:02 2020 +0200 Merge remote-tracking branch 'savahnna/master' into HEAD commit 79ed90380547128b9919d407901a886fed0306b7 Author: Andrea Corallo Date: Sun Jul 26 09:38:14 2020 +0200 * Add NATIVE_COMP to `system-configuration-features' * configure.ac (emacs_config_features): Add NATIVE_COMP diff --git a/configure.ac b/configure.ac index 2277f36e49..cb05930325 100644 --- a/configure.ac +++ b/configure.ac @@ -5725,7 +5725,7 @@ emacs_config_features= for opt in XAW3D XPM JPEG TIFF GIF PNG RSVG CAIRO IMAGEMAGICK SOUND GPM DBUS \ GCONF GSETTINGS GLIB NOTIFY ACL LIBSELINUX GNUTLS LIBXML2 FREETYPE HARFBUZZ M17N_FLT \ LIBOTF XFT ZLIB TOOLKIT_SCROLL_BARS X_TOOLKIT OLDXMENU X11 XDBE XIM \ - NS MODULES THREADS XWIDGETS LIBSYSTEMD JSON PDUMPER UNEXEC LCMS2 GMP; do + NS MODULES NATIVE_COMP THREADS XWIDGETS LIBSYSTEMD JSON PDUMPER UNEXEC LCMS2 GMP; do case $opt in PDUMPER) val=${with_pdumper} ;; commit 6c108e44c9522d1a70ac49c4810ed5927b8b2223 Author: Andrea Corallo Date: Sun Jul 26 09:36:09 2020 +0200 * Add `comp-ensure-native-compiler' guarding entry points * lisp/emacs-lisp/comp.el (comp-ensure-native-compiler): New function. (native-compile, batch-native-compile) (batch-byte-native-compile-for-bootstrap, native-compile-async): Make use of `comp-ensure-native-compiler'. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 24b2a4f6dc..c5027168be 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -417,6 +417,16 @@ structure.") +(defun comp-ensure-native-compiler () + "Make sure Emacs has native compiler support and libgccjit is laodable. +Raise and error otherwise. +To be used by all entry points." + (cond + ((null (boundp 'comp-ctxt)) + (error "Emacs not compiled with native compiler support (--with-nativecomp)")) + ((null (native-comp-available-p)) + (error "Cannot find libgccjit")))) + (defsubst comp-set-op-p (op) "Assignment predicate for OP." (when (memq op comp-limple-sets) t)) @@ -2652,6 +2662,7 @@ FUNCTION-OR-FILE is a function symbol or a path to an Elisp file. When WITH-LATE-LOAD non Nil mark the compilation unit for late load once finished compiling (internal use only). Return the compilation unit file name." + (comp-ensure-native-compiler) (unless (or (functionp function-or-file) (stringp function-or-file)) (signal 'native-compiler-error @@ -2687,6 +2698,7 @@ Return the compilation unit file name." (defun batch-native-compile () "Run `native-compile' on remaining command-line arguments. Ultra cheap impersonation of `batch-byte-compile'." + (comp-ensure-native-compiler) (cl-loop for file in command-line-args-left if (or (null byte-native-for-bootstrap) (cl-notany (lambda (re) (string-match re file)) @@ -2699,6 +2711,7 @@ Ultra cheap impersonation of `batch-byte-compile'." (defun batch-byte-native-compile-for-bootstrap () "As `batch-byte-compile' but used for booststrap. Always generate elc files too and handle native compiler expected errors." + (comp-ensure-native-compiler) (if (equal (getenv "NATIVE_DISABLE") "1") (batch-byte-compile) (cl-assert (= 1 (length command-line-args-left))) @@ -2721,6 +2734,7 @@ PATHS is one path or a list of paths to files or directories. run simultaneously. If RECURSIVELY, recurse into subdirectories of given directories. LOAD can be nil t or 'late." + (comp-ensure-native-compiler) (unless (member load '(nil t late)) (error "LOAD must be nil t or 'late")) (unless (listp paths) commit 37e0dbc97242a69da9f02039f5635261a307659a Merge: 907618b3b5 5d2a83ea0e Author: Andrea Corallo Date: Sun Jul 19 20:39:27 2020 +0100 Merge remote-tracking branch 'savannah/master' into HEAD commit 907618b3b51a653d111d7f5764da586fcee6da5e Merge: 2c2cc21f1b 85eaa8373b Author: Andrea Corallo Date: Wed Jul 15 23:13:59 2020 +0200 Merge remote-tracking branch 'savahnna/master' into HEAD commit 2c2cc21f1be721e5ba30fa22aedeb5c254791193 Author: Andrea Corallo Date: Wed Jul 15 23:01:11 2020 +0200 Add a testcase for bug#42360 * test/src/comp-tests.el (comp-test-42360): New testcase. * test/src/comp-test-funcs.el (comp-test-42360-f): New function. diff --git a/test/src/comp-test-funcs.el b/test/src/comp-test-funcs.el index 2fe6276227..fe9943a1b9 100644 --- a/test/src/comp-test-funcs.el +++ b/test/src/comp-test-funcs.el @@ -290,6 +290,53 @@ (declare (speed -1)) 3) +(defun comp-test-42360-f (str end-column + &optional start-column padding ellipsis + ellipsis-text-property) + ;; From `truncate-string-to-width'. A large enough function to + ;; potentially use all registers and that is modifying local + ;; variables inside condition-case. + (let ((str-len (length str)) + (str-width 14) + (ellipsis-width 3) + (idx 0) + (column 0) + (head-padding "") (tail-padding "") + ch last-column last-idx from-idx) + (condition-case nil + (while (< column start-column) + (setq ch (aref str idx) + column (+ column (char-width ch)) + idx (1+ idx))) + (args-out-of-range (setq idx str-len))) + (if (< column start-column) + (if padding (make-string end-column padding) "") + (when (and padding (> column start-column)) + (setq head-padding (make-string (- column start-column) padding))) + (setq from-idx idx) + (when (>= end-column column) + (condition-case nil + (while (< column end-column) + (setq last-column column + last-idx idx + ch (aref str idx) + column (+ column (char-width ch)) + idx (1+ idx))) + (args-out-of-range (setq idx str-len))) + (when (> column end-column) + (setq column last-column + idx last-idx)) + (when (and padding (< column end-column)) + (setq tail-padding (make-string (- end-column column) padding)))) + (if (and ellipsis-text-property + (not (equal ellipsis "")) + idx) + (concat head-padding + (substring str from-idx idx) + (propertize (substring str idx) 'display (or ellipsis ""))) + (concat head-padding (substring str from-idx idx) + tail-padding ellipsis))))) + ;;;;;;;;;;;;;;;;;;;; ;; Tromey's tests ;; diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 8f0b90f8e0..092504565a 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -363,6 +363,11 @@ https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-03/msg00914.html." (should (= (comp-test-speed--1-f) 3)) (should-not (subr-native-elisp-p (symbol-function #'comp-test-speed--1-f)))) +(ert-deftest comp-test-42360 () + "." + (should (string= (comp-test-42360-f "Nel mezzo del " 18 0 32 "yyy" nil) + "Nel mezzo del yyy"))) + ;;;;;;;;;;;;;;;;;;;;; ;; Tromey's tests. ;; commit 82169a3d97014c3eae5e7bad4aabb9220dd26b3b Author: Andrea Corallo Date: Wed Jul 15 12:15:22 2020 +0200 * Fix bug#42360 * src/comp.c (compile_function): Allocate function frame as array if non local exits are present to retain correct Elisp semantic. (emit_limple_call_ref): Directly use the frame array for ref calls to have GCC spills into it before calling. diff --git a/src/comp.c b/src/comp.c index 8f7a48443c..704bd4b6b3 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1839,6 +1839,17 @@ emit_limple_call_ref (Lisp_Object insn, bool direct) Lisp_Object callee = FIRST (insn); EMACS_INT nargs = XFIXNUM (Flength (CDR (insn))); + if (!nargs) + return emit_call_ref (callee, 0, comp.frame[0], direct); + + if (comp.func_has_non_local || !comp.func_speed) + { + /* FIXME: See bug#42360. */ + Lisp_Object first_arg = SECOND (insn); + EMACS_INT first_slot = XFIXNUM (CALL1I (comp-mvar-slot, first_arg)); + return emit_call_ref (callee, nargs, comp.frame[first_slot], direct); + } + gcc_jit_lvalue *tmp_arr = gcc_jit_function_new_local ( comp.func, @@ -3757,12 +3768,36 @@ compile_function (Lisp_Object func) comp.func_speed = XFIXNUM (CALL1I (comp-func-speed, func)); comp.frame = SAFE_ALLOCA (frame_size * sizeof (*comp.frame)); - for (ptrdiff_t i = 0; i < frame_size; ++i) - comp.frame[i] = - gcc_jit_function_new_local (comp.func, - NULL, - comp.lisp_obj_type, - format_string ("slot_%td", i)); + if (comp.func_has_non_local || !comp.func_speed) + { + /* FIXME: See bug#42360. */ + gcc_jit_lvalue *arr = + gcc_jit_function_new_local ( + comp.func, + NULL, + gcc_jit_context_new_array_type (comp.ctxt, + NULL, + comp.lisp_obj_type, + frame_size), + "frame"); + + for (ptrdiff_t i = 0; i < frame_size; ++i) + comp.frame[i] = + gcc_jit_context_new_array_access ( + comp.ctxt, + NULL, + gcc_jit_lvalue_as_rvalue (arr), + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.int_type, + i)); + } + else + for (ptrdiff_t i = 0; i < frame_size; ++i) + comp.frame[i] = + gcc_jit_function_new_local (comp.func, + NULL, + comp.lisp_obj_type, + format_string ("slot_%td", i)); comp.scratch = NULL; commit 4c46f8bac0ad3ee89ada767a6dd651411c1319a5 Author: Andrea Corallo Date: Mon Jul 13 20:35:20 2020 +0200 * Add a simple major mode for coloring LIMPLE in the log buffer * lisp/emacs-lisp/comp.el (comp-limple-lock-keywords): New const. (comp-limple-mode): New major mode. (comp-log-to-buffer): Enable `comp-limple-mode' in the log buffer. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 065417d1d9..24b2a4f6dc 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -471,6 +471,27 @@ Assume allocaiton class 'd-default as default." (puthash obj t (comp-data-container-idx (comp-alloc-class-to-container comp-curr-allocation-class)))) + +;;; Log rountines. + +(defconst comp-limple-lock-keywords + `((,(rx bol "(comment" (1+ not-newline)) . font-lock-comment-face) + (,(rx "#s(" (group-n 1 "comp-mvar")) + (1 font-lock-function-name-face)) + (,(rx bol "(" (group-n 1 "phi")) + (1 font-lock-variable-name-face)) + (,(rx (group-n 1 (or "entry" + (seq (or "entry_" "entry_fallback_" "bb_") + (1+ num))))) + (1 font-lock-constant-face)) + (,(rx "(" (group-n 1 (1+ (or word "-")))) + (1 font-lock-keyword-face))) + "Highlights used by comp-limple-mode.") + +(define-derived-mode comp-limple-mode fundamental-mode "LIMPLE" + "Syntax highlight LIMPLE IR." + (setf font-lock-defaults '(comp-limple-lock-keywords))) + (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 @@ -495,6 +516,8 @@ log with `comp-log-to-buffer'." (inhibit-read-only t) at-end-p) (with-current-buffer log-buffer + (unless (eq major-mode 'comp-limple-mode) + (comp-limple-mode)) (when (= (point) (point-max)) (setf at-end-p t)) (save-excursion @@ -534,6 +557,8 @@ VERBOSITY is a number between 0 and 3." 2)) edges))) + + (defun comp-output-directory (src) "Return the compilation direcotry for source SRC." (let* ((src (if (symbolp src) (symbol-name src) src)) commit 5be335e6b5d1a948a94206869d75c04684104203 Merge: eb091c8647 46a0c115f0 Author: Andrea Corallo Date: Mon Jul 13 15:13:46 2020 +0200 Merge remote-tracking branch 'savahnna/master' into HEAD commit eb091c8647a7d10b02e49e61f3c5a0ce3d5ec0a4 Author: Andrea Corallo Date: Sun Jul 12 15:05:46 2020 +0200 * Rename `comp-propagate' into `fw-prop' * lisp/emacs-lisp/comp.el (comp-passes): Rename `comp-propagate' -> `comp-fwprop'. (comp-fwprop-prologue): Rename from `comp-propagate-prologue'. (comp-fwprop-insn): Rename from `comp-fwprop-insn'. (comp-propagate*): Rename from `comp-propagate*' and update. (comp-fwprop): Rename from `comp-propagate' and update. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 9e144dc595..065417d1d9 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -162,13 +162,13 @@ Can be one of: 'd-default', 'd-impure' or 'd-ephemeral'. See `comp-ctxt'.") (defconst comp-passes '(comp-spill-lap comp-limplify - comp-propagate + comp-fwprop comp-call-optim comp-ipa-pure - comp-propagate + comp-fwprop comp-dead-code comp-tco - comp-propagate + comp-fwprop comp-remove-type-hints comp-final) "Passes to be executed in order.") @@ -2012,7 +2012,7 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non nil." for (func-name . def) in env do (setf (symbol-function func-name) def))))) -(defun comp-propagate-prologue () +(defun comp-fwprop-prologue () "Prologue for the propagate pass. Here goes everything that can be done not iteratively (read once). Forward propagate immediate involed in assignments." @@ -2066,7 +2066,7 @@ Forward propagate immediate involed in assignments." (value (comp-apply-in-env f (mapcar #'comp-mvar-constant args)))) (rewrite-insn-as-setimm insn value))))))) -(defun comp-propagate-insn (insn) +(defun comp-fwprop-insn (insn) "Propagate within INSN." (pcase insn (`(set ,lval ,rval) @@ -2102,7 +2102,7 @@ Forward propagate immediate involed in assignments." (eqs (cl-every (lambda (y) (eq x y)) types))) (setf (comp-mvar-type lval) x))))) -(defun comp-propagate* () +(defun comp-fwprop* () "Propagate for set* and phi operands. Return t if something was changed." (cl-loop with modified = nil @@ -2110,12 +2110,12 @@ Return t if something was changed." do (cl-loop for insn in (comp-block-insns b) for orig-insn = (unless modified ; Save consing after 1th change. (comp-copy-insn insn)) - do (comp-propagate-insn insn) + do (comp-fwprop-insn insn) when (and (null modified) (not (equal insn orig-insn))) do (setf modified t)) finally return modified)) -(defun comp-propagate (_) +(defun comp-fwprop (_) "Forward propagate types and consts within the lattice." (comp-ssa) (maphash (lambda (_ f) @@ -2123,10 +2123,10 @@ Return t if something was changed." ;; FIXME remove the following condition when tested. (not (comp-func-has-non-local f))) (let ((comp-func f)) - (comp-propagate-prologue) + (comp-fwprop-prologue) (cl-loop for i from 1 - while (comp-propagate*) + while (comp-fwprop*) finally (comp-log (format "Propagation run %d times\n" i) 2)) (comp-log-func comp-func 3)))) (comp-ctxt-funcs-h comp-ctxt))) commit 36c289ec8b848e71729bd8715bc1a606f61711c9 Author: Andrea Corallo Date: Sun Jul 12 12:22:41 2020 +0200 * Clean-up now unnecessary backward propagation in comp.el * lisp/emacs-lisp/comp.el (comp-passes): Invoke 'comp-propagate' instead of 'comp-propagate-alloc'. (comp-mvar): Remove unnecessary `array-idx' slot. (comp-propagate-prologue): Remove. (comp-propagate-prologue): Remove `backward' parameter and backward propagation logic. (comp-propagate1): Remove and move logic into `comp-propagate'. (comp-propagate-alloc): Remove pass. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index caa6613b89..9e144dc595 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -168,7 +168,7 @@ Can be one of: 'd-default', 'd-impure' or 'd-ephemeral'. See `comp-ctxt'.") comp-propagate comp-dead-code comp-tco - comp-propagate-alloc + comp-propagate comp-remove-type-hints comp-final) "Passes to be executed in order.") @@ -400,9 +400,6 @@ structure.") "A meta-variable being a slot in the meta-stack." (id nil :type (or null number) :documentation "Unique id when in SSA form.") - ;; The following two are allocation info. - (array-idx 0 :type fixnum - :documentation "The array where the m-var gets allocated.") (slot nil :type (or fixnum symbol) :documentation "Slot number in the array if a number or 'scratch' for scratch slot.") @@ -2015,42 +2012,15 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non nil." for (func-name . def) in env do (setf (symbol-function func-name) def))))) -(defun comp-ref-args-to-array (args) - "Given ARGS assign them to a dedicated array." - (when args - (cl-loop with array-h = (comp-func-array-h comp-func) - with arr-idx = (hash-table-count array-h) - for i from 0 - for arg in args - initially - (puthash arr-idx (length args) array-h) - do - ;; We are not supposed to rename arrays more then once. - ;; This because we do only one final back propagation - ;; and arrays are used only once. - - ;; Note: this last is just a property of the code generated - ;; by the byte-compiler. - (cl-assert (= (comp-mvar-array-idx arg) 0)) - (setf (comp-mvar-slot arg) i - (comp-mvar-array-idx arg) arr-idx)))) - -(defun comp-propagate-prologue (backward) +(defun comp-propagate-prologue () "Prologue for the propagate pass. Here goes everything that can be done not iteratively (read once). -- Forward propagate immediate involed in assignments. -- Backward propagate array layout when BACKWARD is non nil." +Forward propagate immediate involed in assignments." (cl-loop for b being each hash-value of (comp-func-blocks comp-func) do (cl-loop for insn in (comp-block-insns b) do (pcase insn - (`(set ,_lval (,(or 'callref 'direct-callref) ,_f . ,args)) - (when backward - (comp-ref-args-to-array args))) - (`(,(or 'callref 'direct-callref) ,_f . ,args) - (when backward - (comp-ref-args-to-array args))) (`(setimm ,lval ,v) (setf (comp-mvar-const-vld lval) t (comp-mvar-constant lval) v @@ -2130,15 +2100,7 @@ Here goes everything that can be done not iteratively (read once). (non-empty (cl-notany #'null types)) (x (car types)) (eqs (cl-every (lambda (y) (eq x y)) types))) - (setf (comp-mvar-type lval) x)) - ;; Backward propagate array index and slot. - (let ((arr-idx (comp-mvar-array-idx lval))) - (when (> arr-idx 0) - (cl-loop with slot = (comp-mvar-slot lval) - for arg in rest - do - (setf (comp-mvar-array-idx arg) arr-idx - (comp-mvar-slot arg) slot))))))) + (setf (comp-mvar-type lval) x))))) (defun comp-propagate* () "Propagate for set* and phi operands. @@ -2153,14 +2115,15 @@ Return t if something was changed." do (setf modified t)) finally return modified)) -(defun comp-propagate1 (backward) +(defun comp-propagate (_) + "Forward propagate types and consts within the lattice." (comp-ssa) (maphash (lambda (_ f) (when (and (>= (comp-func-speed f) 2) ;; FIXME remove the following condition when tested. (not (comp-func-has-non-local f))) (let ((comp-func f)) - (comp-propagate-prologue backward) + (comp-propagate-prologue) (cl-loop for i from 1 while (comp-propagate*) @@ -2168,15 +2131,6 @@ Return t if something was changed." (comp-log-func comp-func 3)))) (comp-ctxt-funcs-h comp-ctxt))) -(defun comp-propagate (_) - "Forward propagate types and consts within the lattice." - (comp-propagate1 nil)) - -(defun comp-propagate-alloc (_) - "Forward propagate types and consts within the lattice. -Backward propagate array placement properties." - (comp-propagate1 t)) - ;;; Call optimizer pass specific code. ;; This pass is responsible for the following optimizations: commit 527b697b2a1f57cf47ac74a28b7f89c91dddb1ab Author: Andrea Corallo Date: Sun Jul 12 11:11:41 2020 +0200 * Rework frame allocation strategy All frame slots are now simple automatic variables given the array allocation and fill is done in 'emit_limple_call_ref'. * src/comp.c (comp_t): Remove 'f_frame' 'arrays' slots, add 'frame'. (emit_mvar_lval): Simplify to make use of 'comp.frame'. (compile_function): Clean-up and add comp.frame initialization. diff --git a/src/comp.c b/src/comp.c index 15c223c564..8f7a48443c 100644 --- a/src/comp.c +++ b/src/comp.c @@ -537,10 +537,9 @@ typedef struct { gcc_jit_function *func; /* Current function being compiled. */ bool func_has_non_local; /* From comp-func has-non-local slot. */ EMACS_INT func_speed; /* From comp-func speed slot. */ - gcc_jit_lvalue **f_frame; /* "Floating" frame for the current function. */ gcc_jit_block *block; /* Current basic block being compiled. */ gcc_jit_lvalue *scratch; /* Used as scratch slot for some code sequence (switch). */ - gcc_jit_lvalue ***arrays; /* Array index -> gcc_jit_lvalue **. */ + gcc_jit_lvalue **frame; /* Frame slot n -> gcc_jit_lvalue *. */ gcc_jit_rvalue *zero; gcc_jit_rvalue *one; gcc_jit_rvalue *inttypebits; @@ -734,17 +733,7 @@ emit_mvar_lval (Lisp_Object mvar) return comp.scratch; } - EMACS_INT arr_idx = XFIXNUM (CALL1I (comp-mvar-array-idx, mvar)); - EMACS_INT slot_n = XFIXNUM (mvar_slot); - if (comp.func_has_non_local || (comp.func_speed < 2)) - return comp.arrays[arr_idx][slot_n]; - else - { - if (arr_idx) - return comp.arrays[arr_idx][slot_n]; - else - return comp.f_frame[slot_n]; - } + return comp.frame[XFIXNUM (mvar_slot)]; } static void @@ -3767,54 +3756,13 @@ compile_function (Lisp_Object func) comp.func_has_non_local = !NILP (CALL1I (comp-func-has-non-local, func)); comp.func_speed = XFIXNUM (CALL1I (comp-func-speed, func)); - struct Lisp_Hash_Table *array_h = - XHASH_TABLE (CALL1I (comp-func-array-h, func)); - comp.arrays = SAFE_ALLOCA (array_h->count * sizeof (*comp.arrays)); - for (ptrdiff_t i = 0; i < array_h->count; i++) - { - EMACS_INT array_len = XFIXNUM (HASH_VALUE (array_h, i)); - comp.arrays[i] = SAFE_ALLOCA (array_len * sizeof (**comp.arrays)); - - gcc_jit_lvalue *arr = - gcc_jit_function_new_local ( - comp.func, - NULL, - gcc_jit_context_new_array_type (comp.ctxt, - NULL, - comp.lisp_obj_type, - array_len), - format_string ("arr_%td", i)); - - for (ptrdiff_t j = 0; j < array_len; j++) - comp.arrays[i][j] = - gcc_jit_context_new_array_access ( - comp.ctxt, - NULL, - gcc_jit_lvalue_as_rvalue (arr), - gcc_jit_context_new_rvalue_from_int (comp.ctxt, - comp.int_type, - j)); - } - - /* - The floating frame is a copy of the normal frame that can be used to store - locals if the are not going to be used in a nargs call. - This has two advantages: - - Enable gcc for better reordering (frame array is clobbered every time is - passed as parameter being involved into an nargs function call). - - Allow gcc to trigger other optimizations that are prevented by memory - referencing. - */ - if (comp.func_speed >= 2) - { - comp.f_frame = SAFE_ALLOCA (frame_size * sizeof (*comp.f_frame)); - for (ptrdiff_t i = 0; i < frame_size; ++i) - comp.f_frame[i] = - gcc_jit_function_new_local (comp.func, - NULL, - comp.lisp_obj_type, - format_string ("local%td", i)); - } + comp.frame = SAFE_ALLOCA (frame_size * sizeof (*comp.frame)); + for (ptrdiff_t i = 0; i < frame_size; ++i) + comp.frame[i] = + gcc_jit_function_new_local (comp.func, + NULL, + comp.lisp_obj_type, + format_string ("slot_%td", i)); comp.scratch = NULL; commit c389feede5f1138b23e43edb23564e6ef14d4170 Author: Andrea Corallo Date: Sun Jul 12 10:54:48 2020 +0200 * Rework the backend to allocate arument arrays for call by references * src/comp.c (comp_t): Add 'zero' field. (emit_limple_call_ref): Allocate an array to host the parametes and generate the code moving values into. (Fcomp__init_ctxt): Initialize comp.zero. diff --git a/src/comp.c b/src/comp.c index 2464b58dad..15c223c564 100644 --- a/src/comp.c +++ b/src/comp.c @@ -541,6 +541,7 @@ typedef struct { gcc_jit_block *block; /* Current basic block being compiled. */ gcc_jit_lvalue *scratch; /* Used as scratch slot for some code sequence (switch). */ gcc_jit_lvalue ***arrays; /* Array index -> gcc_jit_lvalue **. */ + gcc_jit_rvalue *zero; gcc_jit_rvalue *one; gcc_jit_rvalue *inttypebits; gcc_jit_rvalue *lisp_int0; @@ -1845,31 +1846,46 @@ emit_limple_call_ref (Lisp_Object insn, bool direct) /* Ex: (funcall #s(comp-mvar 1 5 t eql symbol t) #s(comp-mvar 2 6 nil nil nil t) #s(comp-mvar 3 7 t 0 fixnum t)). */ - + static int i = 0; Lisp_Object callee = FIRST (insn); EMACS_INT nargs = XFIXNUM (Flength (CDR (insn))); - if (!nargs) - return emit_call_ref (callee, - nargs, - comp.arrays[0][0], - direct); - - Lisp_Object first_arg = SECOND (insn); - Lisp_Object arr_idx = CALL1I (comp-mvar-array-idx, first_arg); + gcc_jit_lvalue *tmp_arr = + gcc_jit_function_new_local ( + comp.func, + NULL, + gcc_jit_context_new_array_type (comp.ctxt, + NULL, + comp.lisp_obj_type, + nargs), + format_string ("call_arr_%d", i++)); - /* Make sure all the arguments are layout-ed into the same array. */ - Lisp_Object p = XCDR (XCDR (insn)); - FOR_EACH_TAIL (p) - if (!EQ (arr_idx, CALL1I (comp-mvar-array-idx, XCAR (p)))) - xsignal2 (Qnative_ice, build_string ("incoherent array idx for insn"), - insn); + ptrdiff_t j = 0; + Lisp_Object arg = CDR (insn); + FOR_EACH_TAIL (arg) + { + gcc_jit_block_add_assignment ( + comp.block, + NULL, + gcc_jit_context_new_array_access ( + comp.ctxt, + NULL, + gcc_jit_lvalue_as_rvalue (tmp_arr), + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.int_type, + j)), + emit_mvar_rval (XCAR (arg))); + ++j; + } - EMACS_INT first_slot = XFIXNUM (CALL1I (comp-mvar-slot, first_arg)); - return emit_call_ref (callee, - nargs, - comp.arrays[XFIXNUM (arr_idx)][first_slot], - direct); + return emit_call_ref ( + callee, + nargs, + gcc_jit_context_new_array_access (comp.ctxt, + NULL, + gcc_jit_lvalue_as_rvalue (tmp_arr), + comp.zero), + direct); } static gcc_jit_rvalue * @@ -3966,6 +3982,10 @@ DEFUN ("comp--init-ctxt", Fcomp__init_ctxt, Scomp__init_ctxt, comp.lisp_obj_type = comp.lisp_word_type; #endif comp.lisp_obj_ptr_type = gcc_jit_type_get_pointer (comp.lisp_obj_type); + comp.zero = + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.emacs_int_type, + 0); comp.one = gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.emacs_int_type, commit 5f13016cedd245a7388ffafddffa20268afaf023 Merge: 02bf2e08e2 19cf8e5be7 Author: Andrea Corallo Date: Thu Jul 9 16:42:16 2020 +0100 Merge remote-tracking branch 'savannah/master' into wip2 commit 02bf2e08e27a00cde891a20affe96653fe44c7da Author: Andrea Corallo Date: Wed Jul 8 20:57:20 2020 +0100 * Disable ipa-pure in comp-tests-tco * test/src/comp-tests.el (comp-tests-tco): Disable ipa-pure to check effectively for tail recursion elimination. diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index f4bc8156d3..8f0b90f8e0 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -629,6 +629,9 @@ CHECKER should always return nil to have a pass." (ert-deftest comp-tests-tco () "Check for tail recursion elimination." (let ((comp-speed 3) + ;; Disable ipa-pure otherwise `comp-tests-tco-f' gets + ;; optimized-out. + (comp-disabled-passes '(comp-ipa-pure)) (comp-post-pass-hooks '((comp-tco comp-tests-tco-checker) (comp-final comp-tests-tco-checker)))) (eval '(defun comp-tests-tco-f (a b count) commit 9aaca828fc6a20d99e72c98e79a3b789827b25e1 Author: Andrea Corallo Date: Wed Jul 8 14:23:09 2020 +0100 * Add `comp-disabled-passes' * lisp/emacs-lisp/comp.el (comp-disabled-passes): New special variable. (native-compile): Make use of `comp-disabled-passes'. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 5ff2e09837..caa6613b89 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -173,6 +173,10 @@ Can be one of: 'd-default', 'd-impure' or 'd-ephemeral'. See `comp-ctxt'.") comp-final) "Passes to be executed in order.") +(defvar comp-disabled-passes '() + "List of disabled passes. +For internal use only by the testsuite.") + (defvar comp-post-pass-hooks () "Alist PASS FUNCTIONS. Each function in FUNCTIONS is run after PASS. @@ -2684,12 +2688,13 @@ Return the compilation unit file name." (comp-log "\n \n" 1) (condition-case err (mapc (lambda (pass) - (comp-log (format "(%s) Running pass %s:\n" - function-or-file pass) - 2) - (setf data (funcall pass data)) - (cl-loop for f in (alist-get pass comp-post-pass-hooks) - do (funcall f data))) + (unless (memq pass comp-disabled-passes) + (comp-log (format "(%s) Running pass %s:\n" + function-or-file pass) + 2) + (setf data (funcall pass data)) + (cl-loop for f in (alist-get pass comp-post-pass-hooks) + do (funcall f data)))) comp-passes) (native-compiler-error ;; Add source input. commit 92e744d787551e339e6ddb4244008820e72b06ed Author: Andrea Corallo Date: Sun Jul 5 23:00:14 2020 +0100 ;* test/src/comp-test-funcs-dyn.el: Fix comment header. diff --git a/test/src/comp-test-funcs-dyn.el b/test/src/comp-test-funcs-dyn.el index 5f12378bcf..67db7587bf 100644 --- a/test/src/comp-test-funcs-dyn.el +++ b/test/src/comp-test-funcs-dyn.el @@ -1,4 +1,4 @@ -;;; comp-test-funcs.el --- compilation unit tested by comp-tests.el -*- lexical-binding: nil; -*- +;;; comp-test-funcs-dyn.el --- compilation unit tested by comp-tests.el -*- lexical-binding: nil; -*- ;; Copyright (C) 2020 Free Software Foundation, Inc. commit a53b446cb021d1afb30b5c86a9b9cb7512dcf55d Author: Andrea Corallo Date: Sun Jul 5 23:00:07 2020 +0100 Add some tests for pure function optimization * test/src/comp-tests.el (comp-tests-fw-prop): Fix docstring. (comp-tests-pure-checker-1, comp-tests-pure-checker-2): New functions. (comp-tests-pure): New test testing for pure function optimization. diff --git a/test/src/comp-test-pure.el b/test/src/comp-test-pure.el new file mode 100644 index 0000000000..f606a44a10 --- /dev/null +++ b/test/src/comp-test-pure.el @@ -0,0 +1,40 @@ +;;; comp-test-pure.el --- compilation unit tested by comp-tests.el -*- lexical-binding: t; -*- + +;; Copyright (C) 2020 Free Software Foundation, Inc. + +;; Author: Andrea Corallo + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;;; Code: + +(defun comp-tests-pure-callee-f (x) + (1+ x)) + +(defun comp-tests-pure-caller-f () + (comp-tests-pure-callee-f 3)) + +(defun comp-tests-pure-fibn-f (a b count) + (if (= count 0) + b + (comp-tests-pure-fibn-f (+ a b) a (- count 1)))) + +(defun comp-tests-pure-fibn-entry-f () + (comp-tests-pure-fibn-f 1 0 20)) + +;;; comp-test-pure.el ends here diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 332facb4cf..f4bc8156d3 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -662,4 +662,36 @@ CHECKER should always return nil to have a pass." (should (subr-native-elisp-p (symbol-function #'comp-tests-fw-prop-1-f))) (should (= (comp-tests-fw-prop-1-f) 6)))) +(defun comp-tests-pure-checker-1 (_) + "Check that inside `comp-tests-pure-caller-f' `comp-tests-pure-callee-f' is + folded." + (comp-tests-make-insn-checker + 'comp-tests-pure-caller-f + (lambda (insn) + (or (comp-tests-mentioned-p 'comp-tests-pure-callee-f insn) + (comp-tests-mentioned-p (comp-c-func-name 'comp-tests-pure-callee-f "F" t) + insn))))) + +(defun comp-tests-pure-checker-2 (_) + "Check that `comp-tests-pure-fibn-f' is folded." + (comp-tests-make-insn-checker + 'comp-tests-pure-fibn-entry-f + (lambda (insn) + (or (comp-tests-mentioned-p 'comp-tests-pure-fibn-f insn) + (comp-tests-mentioned-p (comp-c-func-name 'comp-tests-pure-fibn-f "F" t) + insn))))) + +(ert-deftest comp-tests-pure () + "Some tests for pure functions optimization." + (let ((comp-speed 3) + (comp-post-pass-hooks '((comp-final comp-tests-pure-checker-1 + comp-tests-pure-checker-2)))) + (load (native-compile (concat comp-test-directory "comp-test-pure.el"))) + + (should (subr-native-elisp-p (symbol-function #'comp-tests-pure-caller-f))) + (should (= (comp-tests-pure-caller-f) 4)) + + (should (subr-native-elisp-p (symbol-function #'comp-tests-pure-fibn-entry-f))) + (should (= (comp-tests-pure-fibn-entry-f) 6765)))) + ;;; comp-tests.el ends here commit b4de6baa7b5cc41d15bc94cfcdbea680af6dc7b8 Author: Andrea Corallo Date: Sun Jul 5 22:05:36 2020 +0100 * Optimize pure functions defined by the compilation environment * lisp/emacs-lisp/comp.el (comp-apply-in-env): New macro. (comp-function-call-maybe-remove): Update to make use of `comp-apply-in-env'. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 000af0a8b3..5ff2e09837 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1995,6 +1995,22 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non nil." (copy-comp-mvar insn) insn))) +(defmacro comp-apply-in-env (func &rest args) + "Apply FUNC to ARGS in the current compilation environment." + `(let ((env (cl-loop + for f being the hash-value in (comp-ctxt-funcs-h comp-ctxt) + for func-name = (comp-func-name f) + for byte-code = (comp-func-byte-func f) + when func-name + collect `(,func-name . ,(symbol-function func-name)) + and do + (setf (symbol-function func-name) byte-code)))) + (unwind-protect + (apply ,func ,@args) + (cl-loop + for (func-name . def) in env + do (setf (symbol-function func-name) def))))) + (defun comp-ref-args-to-array (args) "Given ARGS assign them to a dedicated array." (when args @@ -2064,13 +2080,17 @@ Here goes everything that can be done not iteratively (read once). (car args)))))) ((comp-function-optimizable-p f args) (ignore-errors - ;; No point to complain here because we should do basic block - ;; pruning in order to be sure that this is not dead-code. This - ;; is now left to gcc, to be implemented only if we want a - ;; reliable diagnostic here. - (rewrite-insn-as-setimm insn - (apply f - (mapcar #'comp-mvar-constant args)))))))) + ;; No point to complain here in case of error because we + ;; should do basic block pruning in order to be sure that this + ;; is not dead-code. This is now left to gcc, to be + ;; implemented only if we want a reliable diagnostic here. + (let* ((f (if-let (f-in-ctxt (comp-symbol-func-to-fun f)) + ;; If the function is IN the compilation ctxt + ;; and know to be pure. + (comp-func-byte-func f-in-ctxt) + f)) + (value (comp-apply-in-env f (mapcar #'comp-mvar-constant args)))) + (rewrite-insn-as-setimm insn value))))))) (defun comp-propagate-insn (insn) "Propagate within INSN." commit 7622740e2930fea33b3381337063d2e8fb834709 Author: Andrea Corallo Date: Sun Jul 5 20:26:36 2020 +0100 * Introduce a new pass ipa-pure Add a simple pass to infer pure functions not explicitly declared as such. Use this information only during compilation (speed 3) to optimize out function calls whe possible. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 46b09fe352..000af0a8b3 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -164,6 +164,7 @@ Can be one of: 'd-default', 'd-impure' or 'd-ephemeral'. See `comp-ctxt'.") comp-limplify comp-propagate comp-call-optim + comp-ipa-pure comp-propagate comp-dead-code comp-tco @@ -379,7 +380,7 @@ structure.") (speed nil :type number :documentation "Optimization level (see `comp-speed').") (pure nil :type boolean - :documentation "t if declared pure nil otherwise.")) + :documentation "t if pure nil otherwise.")) (cl-defstruct (comp-func-l (:include comp-func)) "Lexical scoped function." @@ -1601,6 +1602,61 @@ into the C code forwarding the compilation unit." (when (comp-ctxt-with-late-load comp-ctxt) (comp-add-func-to-ctxt (comp-limplify-top-level t)))) + +;;; pure-func pass specific code. + +;; Simple IPA pass to infer function purity of functions not +;; explicitly declared as such. This is effective only at speed 3 to +;; avoid optimizing-out functions and preventing their redefinition +;; being effective. + +(defun comp-collect-calls (f) + "Return a list with all the functions called by F." + (cl-loop + with h = (make-hash-table :test #'eq) + for b being each hash-value of (comp-func-blocks f) + do (cl-loop + for insn in (comp-block-insns b) + do (pcase insn + (`(set ,_lval (,(pred comp-call-op-p) ,f . ,_rest)) + (puthash f t h)) + (`(,(pred comp-call-op-p) ,f . ,_rest) + (puthash f t h)))) + finally return (cl-loop + for f being each hash-key of h + collect (if (stringp f) + (comp-func-name + (gethash f + (comp-ctxt-funcs-h comp-ctxt))) + f)))) + +(defun comp-pure-infer-func (f) + "If all funtions called by F are pure then F is pure too." + (when (and (cl-every (lambda (x) + (or (comp-function-pure-p x) + (eq x (comp-func-name f)))) + (comp-collect-calls f)) + (not (eq (comp-func-pure f) t))) + (comp-log (format "%s inferred to be pure" (comp-func-name f))) + (setf (comp-func-pure f) t))) + +(defun comp-ipa-pure (_) + "Infer function purity." + (cl-loop + with pure-n = 0 + for n from 1 + while + (/= pure-n + (setf pure-n + (cl-loop + for f being each hash-value of (comp-ctxt-funcs-h comp-ctxt) + when (and (>= (comp-func-speed f) 3) + (comp-func-l-p f) + (not (comp-func-pure f))) + do (comp-pure-infer-func f) + count (comp-func-pure f)))) + finally (comp-log (format "ipa-pure iterated %d times" n)))) + ;;; SSA pass specific code. ;; After limplification no edges are present between basic blocks and an commit 5688739c5bd742e5665f58cdcb2c588990c3f416 Author: Andrea Corallo Date: Sun Jul 5 20:00:46 2020 +0100 * Add `comp-call-op-p' * lisp/emacs-lisp/comp.el (comp-call-op-p): New predicate. (comp-limple-insn-call-p): Make use of. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 22575e415f..46b09fe352 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -423,9 +423,13 @@ structure.") "Assignment predicate for OP." (when (memq op comp-limple-assignments) t)) +(defsubst comp-call-op-p (op) + "Call predicate for OP." + (when (memq op comp-limple-calls) t)) + (defsubst comp-limple-insn-call-p (insn) "Limple INSN call predicate." - (when (memq (car-safe insn) comp-limple-calls) t)) + (comp-call-op-p (car-safe insn))) (defsubst comp-type-hint-p (func) "Type hint predicate for function name FUNC." commit 4348969536f2d2a16e794ff3ce15f855f9ec7e1e Author: Andrea Corallo Date: Sun Jul 5 19:45:10 2020 +0100 * test/src/comp-test-funcs.el (comp-tests-aref-aset-f) : Fix UB. diff --git a/test/src/comp-test-funcs.el b/test/src/comp-test-funcs.el index 168819b17d..2fe6276227 100644 --- a/test/src/comp-test-funcs.el +++ b/test/src/comp-test-funcs.el @@ -66,7 +66,7 @@ (length '(1 2 3))) (defun comp-tests-aref-aset-f () - (let ((vec [1 2 3])) + (let ((vec (make-vector 3 0))) (aset vec 2 100) (aref vec 2))) commit 3db6ace804472ccde368e173df21484f19049317 Author: Andrea Corallo Date: Sun Jul 5 18:32:32 2020 +0100 * Define `comp-symbol-func-to-fun' * lisp/emacs-lisp/comp.el (comp-symbol-func-to-fun): New function. (comp-func-in-unit): Make use of the `comp-symbol-func-to-fun'. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index ef9dc5ba1d..22575e415f 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -443,13 +443,16 @@ structure.") finally return t) t)) +(defsubst comp-symbol-func-to-fun (symbol-funcion) + "Given a function called SYMBOL-FUNCION return its `comp-func'." + (gethash (gethash symbol-funcion (comp-ctxt-sym-to-c-name-h + comp-ctxt)) + (comp-ctxt-funcs-h comp-ctxt))) + (defsubst comp-function-pure-p (f) "Return t if F is pure." (or (get f 'pure) - (when-let ((func (gethash (gethash f - (comp-ctxt-sym-to-c-name-h - comp-ctxt)) - (comp-ctxt-funcs-h comp-ctxt)))) + (when-let ((func (comp-symbol-func-to-fun f))) (comp-func-pure func)))) (defsubst comp-alloc-class-to-container (alloc-class) @@ -2110,9 +2113,7 @@ Backward propagate array placement properties." "Given FUNC return the `comp-fun' definition in the current context. FUNCTION can be a function-name or byte compiled function." (if (symbolp func) - (gethash (gethash func - (comp-ctxt-sym-to-c-name-h comp-ctxt)) - (comp-ctxt-funcs-h comp-ctxt)) + (comp-symbol-func-to-fun func) (cl-assert (byte-code-function-p func)) (gethash func (comp-ctxt-byte-func-to-func-h comp-ctxt)))) commit e6ab4e3dfe2bfc6e935b4cfa7e8f686e5d926235 Author: Andrea Corallo Date: Sun Jul 5 11:11:11 2020 +0100 * Add a test targeting forward propagation * test/src/comp-tests.el (comp-tests-fw-prop-checker-1): New function. (comp-tests-fw-prop): New test. diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index aefb2f0601..332facb4cf 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -640,4 +640,26 @@ CHECKER should always return nil to have a pass." (should (subr-native-elisp-p (symbol-function #'comp-tests-tco-f))) (should (= (comp-tests-tco-f 1 0 10) 55)))) +(defun comp-tests-fw-prop-checker-1 (_) + "Check that inside `comp-tests-fw-prop-f' `concat' and `length' are folded." + (comp-tests-make-insn-checker + 'comp-tests-fw-prop-1-f + (lambda (insn) + (or (comp-tests-mentioned-p 'concat insn) + (comp-tests-mentioned-p 'length insn))))) + +(ert-deftest comp-tests-fw-prop () + "Some tests for forward propagation." + (let ((comp-speed 2) + (comp-post-pass-hooks '((comp-final comp-tests-fw-prop-checker-1)))) + (eval '(defun comp-tests-fw-prop-1-f () + (let* ((a "xxx") + (b "yyy") + (c (concat a b))) ; <= has to optimize + (length c))) ; <= has to optimize + t) + (load (native-compile #'comp-tests-fw-prop-1-f)) + (should (subr-native-elisp-p (symbol-function #'comp-tests-fw-prop-1-f))) + (should (= (comp-tests-fw-prop-1-f) 6)))) + ;;; comp-tests.el ends here commit b31b0ebefef3c9ea378342f624ce18a0eb6d30ae Author: Andrea Corallo Date: Sun Jul 5 10:23:46 2020 +0100 * Rework some test logic for generality * test/src/comp-tests.el (comp-tests-make-insn-checker): New function splitting logic from `comp-tests-tco-checker' to have it more general. (comp-tests-tco-checker): Make use of `comp-tests-make-insn-checker'. diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index fd1c513d13..aefb2f0601 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -603,19 +603,28 @@ https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-03/msg00914.html." 'comment) (comp-tests-mentioned-p-1 x insn))) -(defun comp-tests-tco-checker (_) - "Check that inside `comp-tests-tco-f' we have no recursion." +(defun comp-tests-make-insn-checker (func-name checker) + "Apply CHECKER to each insn in FUNC-NAME. +CHECKER should always return nil to have a pass." (should-not (cl-loop named checker-loop - with func-name = (comp-c-func-name 'comp-tests-tco-f "F" t) - with f = (gethash func-name (comp-ctxt-funcs-h comp-ctxt)) + with func-c-name = (comp-c-func-name func-name "F" t) + with f = (gethash func-c-name (comp-ctxt-funcs-h comp-ctxt)) for bb being each hash-value of (comp-func-blocks f) do (cl-loop for insn in (comp-block-insns bb) - when (or (comp-tests-mentioned-p 'comp-tests-tco-f insn) - (comp-tests-mentioned-p func-name insn)) - do (cl-return-from checker-loop 'mentioned))))) + when (funcall checker insn) + do (cl-return-from checker-loop 'mentioned))))) + +(defun comp-tests-tco-checker (_) + "Check that inside `comp-tests-tco-f' we have no recursion." + (comp-tests-make-insn-checker + 'comp-tests-tco-f + (lambda (insn) + (or (comp-tests-mentioned-p 'comp-tests-tco-f insn) + (comp-tests-mentioned-p (comp-c-func-name 'comp-tests-tco-f "F" t) + insn))))) (ert-deftest comp-tests-tco () "Check for tail recursion elimination." commit 0b81044e7e7500fcee3f984c1abeaa544118c5ee Author: Andrea Corallo Date: Sun Jul 5 10:21:21 2020 +0100 * Clean-up some const folding logic and add `comp-function-pure-p' * lisp/emacs-lisp/comp.el (comp-function-pure-p): New predicate. (comp-function-call-maybe-remove): Update to use the `comp-function-pure-p'. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index da567fd905..ef9dc5ba1d 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -443,6 +443,15 @@ structure.") finally return t) t)) +(defsubst comp-function-pure-p (f) + "Return t if F is pure." + (or (get f 'pure) + (when-let ((func (gethash (gethash f + (comp-ctxt-sym-to-c-name-h + comp-ctxt)) + (comp-ctxt-funcs-h comp-ctxt)))) + (comp-func-pure func)))) + (defsubst comp-alloc-class-to-container (alloc-class) "Given ALLOC-CLASS return the data container for the current context. Assume allocaiton class 'd-default as default." @@ -1899,17 +1908,6 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non nil." ;; This is also responsible for removing function calls to pure functions if ;; possible. -(defvar comp-propagate-classes '(byte-optimize-associative-math - byte-optimize-binary-predicate - byte-optimize-concat - byte-optimize-equal - byte-optimize-identity - byte-optimize-member - byte-optimize-memq - byte-optimize-predicate) - "We optimize functions with 'byte-optimizer' property set to - one of these symbols. See byte-opt.el.") - (defsubst comp-strict-type-of (obj) "Given OBJ return its type understanding fixnums." ;; Should be certainly smarter but now we take advantages just from fixnums. @@ -1981,21 +1979,10 @@ Here goes everything that can be done not iteratively (read once). (comp-mvar-constant lval) (comp-mvar-constant rval) (comp-mvar-type lval) (comp-mvar-type rval))) -;; Here should fall most of (defun byte-optimize-* equivalents. (defsubst comp-function-optimizable-p (f args) "Given function F called with ARGS return non nil when optimizable." - (when (cl-every #'comp-mvar-const-vld args) - (or (when-let ((func (gethash (gethash f - (comp-ctxt-sym-to-c-name-h - comp-ctxt)) - (comp-ctxt-funcs-h comp-ctxt)))) - (comp-func-pure func)) - (get f 'pure) - (memq (get f 'byte-optimizer) comp-propagate-classes) - (let ((values (mapcar #'comp-mvar-constant args))) - (pcase f - ((or '+ '- '* '1+ '-1) t) - ('/ (not (= (car (last values)) 0)))))))) + (and (cl-every #'comp-mvar-const-vld args) + (comp-function-pure-p f))) (defsubst comp-function-call-maybe-remove (insn f args) "Given INSN when F is pure if all ARGS are known remove the function call." commit 3d43d45755b2c38d5378496ff6b0fc40538ee924 Merge: 2593bbee51 df3ece9d2e Author: Andrea Corallo Date: Tue Jul 7 20:44:39 2020 +0100 Merge remote-tracking branch 'savannah/master' into HEAD commit 2593bbee51f4d15d3a4fc1d4e2e3b215222f783a Author: Andrea Corallo Date: Sat Jul 4 15:53:15 2020 +0100 * Relax constant folding rules * lisp/emacs-lisp/comp.el (comp-function-optimizable-p): No need to check for operands or result to be fixnums. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 81612398c7..da567fd905 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1994,13 +1994,8 @@ Here goes everything that can be done not iteratively (read once). (memq (get f 'byte-optimizer) comp-propagate-classes) (let ((values (mapcar #'comp-mvar-constant args))) (pcase f - ;; Simple integer operation. - ;; Note: byte-opt uses `byte-opt--portable-numberp' - ;; instead of just`fixnump'. - ((or '+ '- '* '1+ '-1) (and (cl-every #'fixnump values) - (fixnump (apply f values)))) - ('/ (and (cl-every #'fixnump values) - (not (= (car (last values)) 0))))))))) + ((or '+ '- '* '1+ '-1) t) + ('/ (not (= (car (last values)) 0)))))))) (defsubst comp-function-call-maybe-remove (insn f args) "Given INSN when F is pure if all ARGS are known remove the function call." commit b0f683ec16ae55f2788e21e30db21044766fcad9 Author: Andrea Corallo Date: Thu Jul 2 21:45:42 2020 +0200 * Fix missing tail recursion elimination * lisp/emacs-lisp/comp.el (comp-tco-func): Fix tail recursion elimination given now functions in LIMPLE are expressed with the C name. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index a16cf1dcc8..81612398c7 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2299,7 +2299,7 @@ Return the list of m-var ids nuked." (`((set ,l-val (direct-call ,func . ,args)) (comment ,_comment) (return ,ret-val)) - (when (and (eq func (comp-func-name comp-func)) + (when (and (string= func (comp-func-c-name comp-func)) (eq l-val ret-val)) (let ((tco-seq (comp-form-tco-call-seq args))) (setf (car insns-seq) (car tco-seq) commit 7e004d24a4abaa4b5aa9f0f1cd4bc70264396ad5 Author: Andrea Corallo Date: Thu Jul 2 21:43:52 2020 +0200 * Add a test to verify tail recursion elimination * test/src/comp-tests.el (comp-tests-tco): Compile a recursive functions at speed 3 and verify the tail recursion elimination. (comp-tests-tco-checker, comp-tests-mentioned-p) (comp-tests-mentioned-p-1): New support functions. diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 66f7d8c179..fd1c513d13 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -583,4 +583,52 @@ https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-03/msg00914.html." (should (equal (comp-tests-cl-uninterned-arg-parse-f 1 2) '(1 2)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Middle-end specific tests. ;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun comp-tests-mentioned-p-1 (x insn) + (cl-loop for y in insn + when (cond + ((consp y) (comp-tests-mentioned-p x y)) + ((and (comp-mvar-p y) (comp-mvar-const-vld y)) + (equal (comp-mvar-constant y) x)) + (t (equal x y))) + return t)) + +(defun comp-tests-mentioned-p (x insn) + "Check if X is actively mentioned in INSN." + (unless (eq (car-safe insn) + 'comment) + (comp-tests-mentioned-p-1 x insn))) + +(defun comp-tests-tco-checker (_) + "Check that inside `comp-tests-tco-f' we have no recursion." + (should-not + (cl-loop + named checker-loop + with func-name = (comp-c-func-name 'comp-tests-tco-f "F" t) + with f = (gethash func-name (comp-ctxt-funcs-h comp-ctxt)) + for bb being each hash-value of (comp-func-blocks f) + do (cl-loop + for insn in (comp-block-insns bb) + when (or (comp-tests-mentioned-p 'comp-tests-tco-f insn) + (comp-tests-mentioned-p func-name insn)) + do (cl-return-from checker-loop 'mentioned))))) + +(ert-deftest comp-tests-tco () + "Check for tail recursion elimination." + (let ((comp-speed 3) + (comp-post-pass-hooks '((comp-tco comp-tests-tco-checker) + (comp-final comp-tests-tco-checker)))) + (eval '(defun comp-tests-tco-f (a b count) + (if (= count 0) + b + (comp-tests-tco-f (+ a b) a (- count 1)))) + t) + (load (native-compile #'comp-tests-tco-f)) + (should (subr-native-elisp-p (symbol-function #'comp-tests-tco-f))) + (should (= (comp-tests-tco-f 1 0 10) 55)))) + ;;; comp-tests.el ends here commit 8f81859497b7dd0c537d24a27985a26ffc778a3a Author: Andrea Corallo Date: Thu Jul 2 21:32:09 2020 +0200 Rework `comp-c-func-name' arguments * lisp/emacs-lisp/comp.el (comp-c-func-name): Add FIRST argument to ignore the compiler context and return the first name. * lisp/emacs-lisp/disass.el (disassemble-internal): Update the `comp-c-func-name' call. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 205966f57c..a16cf1dcc8 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -566,9 +566,11 @@ instruction." (or (comp-spill-decl-spec function-name 'speed) comp-speed)) -(defun comp-c-func-name (name prefix) +(defun comp-c-func-name (name prefix &optional first) "Given NAME return a name suitable for the native code. -Put PREFIX in front of it." +Add PREFIX in front of it. If FIRST is not nil pick the first +available name ignoring compilation context and potential name +clashes." ;; Unfortunatelly not all symbol names are valid as C function names... ;; Nassi's algorithm here: (let* ((orig-name (if (symbolp name) (symbol-name name) name)) @@ -583,7 +585,7 @@ Put PREFIX in front of it." "-" "_" orig-name)) (human-readable (replace-regexp-in-string (rx (not (any "0-9a-z_"))) "" human-readable))) - (if comp-ctxt + (if (null first) ;; Prevent C namespace conflicts. (cl-loop with h = (comp-ctxt-funcs-h comp-ctxt) diff --git a/lisp/emacs-lisp/disass.el b/lisp/emacs-lisp/disass.el index 82c8de6e13..aa8b248f39 100644 --- a/lisp/emacs-lisp/disass.el +++ b/lisp/emacs-lisp/disass.el @@ -96,7 +96,7 @@ redefine OBJECT if it is a symbol." (regexp-quote (concat "<" (comp-c-func-name - (subr-name obj) "F") + (subr-name obj) "F" t) ">:")))) (beginning-of-line) (delete-region (point-min) (point)) commit b67e156041fb4bb3bc4a2cc60bca4408d092b59b Author: Andrea Corallo Date: Thu Jul 2 21:29:34 2020 +0200 * Add to possibility to write per pass specific tests * lisp/emacs-lisp/comp.el (comp-post-pass-hooks): New special variable. (native-compile): Run what is registered in `comp-post-pass-hooks'. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 39b47f079e..205966f57c 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -172,6 +172,11 @@ Can be one of: 'd-default', 'd-impure' or 'd-ephemeral'. See `comp-ctxt'.") comp-final) "Passes to be executed in order.") +(defvar comp-post-pass-hooks () + "Alist PASS FUNCTIONS. +Each function in FUNCTIONS is run after PASS. +Useful to hook into pass checkers.") + (defconst comp-known-ret-types '((cons . cons) (1+ . number) (1- . number) @@ -2617,7 +2622,9 @@ Return the compilation unit file name." (comp-log (format "(%s) Running pass %s:\n" function-or-file pass) 2) - (setf data (funcall pass data))) + (setf data (funcall pass data)) + (cl-loop for f in (alist-get pass comp-post-pass-hooks) + do (funcall f data))) comp-passes) (native-compiler-error ;; Add source input. commit 25bdf99713ab21eb240d727591b638cc75ad7cf6 Merge: 0f964db327 5d1bac0ac9 Author: Andrea Corallo Date: Thu Jul 2 22:30:37 2020 +0200 Merge remote-tracking branch 'savahnna/master' into HEAD commit 0f964db32797c1525941046d565acdcfa33af42f Author: Andrea Corallo Date: Tue Jun 30 19:14:52 2020 +0200 Add a test for lambda list containing uninterned symbols * test/src/comp-test-funcs-dyn.el (comp-tests-cl-uninterned-arg-parse-f): New function. * test/src/comp-tests.el (comp-tests-cl-uninterned-arg-parse-f): New test. diff --git a/test/src/comp-test-funcs-dyn.el b/test/src/comp-test-funcs-dyn.el index 50a72807be..5f12378bcf 100644 --- a/test/src/comp-test-funcs-dyn.el +++ b/test/src/comp-test-funcs-dyn.el @@ -42,6 +42,9 @@ for yyy = xxx collect xxx)) +(cl-defun comp-tests-cl-uninterned-arg-parse-f (a &optional b &aux) + (list a b)) + (provide 'comp-test-dyn-funcs) ;;; comp-test-funcs-dyn.el ends here diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index fe818960dd..66f7d8c179 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -578,4 +578,9 @@ https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-03/msg00914.html." "Verify CL macro expansion (bug#42088)." (should (equal (comp-tests-cl-macro-exp-f) '(a b)))) +(ert-deftest comp-tests-cl-uninterned-arg-parse-f () + "Verify the parsing of a lambda list with uninterned symbols (bug#42120)." + (should (equal (comp-tests-cl-uninterned-arg-parse-f 1 2) + '(1 2)))) + ;;; comp-tests.el ends here commit 4681f330714b1ac1114f79d6bd2ac33150e1fcc4 Author: Andrea Corallo Date: Tue Jun 30 19:10:19 2020 +0200 Fix lambda-list relocation class Lambda-lists must stay in the same relocation class of the object referenced by code to respect uninterned symbols. * lisp/emacs-lisp/comp.el (comp-prepare-args-for-top-level): Break the original function in a generic specializing for dynamic/lexical functions. When allocating the lambda-list for dynamic functions do that in the default relocation class. (comp-emit-for-top-level): Make use of the new `comp-prepare-args-for-top-level'. (comp-emit-lambda-for-top-level): Likewise. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index cde9899d26..39b47f079e 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1365,16 +1365,25 @@ the annotation emission." (comp-log-func func 2) func) -(defun comp-prepare-args-for-top-level (function) - "Given FUNCTION return the two args arguments for comp--register-..." - (if (comp-func-l-p function) - (let ((args (comp-func-l-args function))) - (cons (comp-args-base-min args) - (if (comp-args-p args) - (comp-args-max args) - 'many))) - (cons (func-arity (comp-func-byte-func function)) - (comp-func-d-lambda-list function)))) +(cl-defgeneric comp-prepare-args-for-top-level (function) + "Given FUNCTION return the two args arguments for comp--register-...") + +(cl-defmethod comp-prepare-args-for-top-level ((function comp-func-l)) + "Lexical scoped FUNCTION." + (let ((args (comp-func-l-args function))) + (cons (make-comp-mvar :constant (comp-args-base-min args)) + (make-comp-mvar :constant (if (comp-args-p args) + (comp-args-max args) + 'many))))) + +(cl-defmethod comp-prepare-args-for-top-level ((function comp-func-d)) + "Dynamic scoped FUNCTION." + (cons (make-comp-mvar :constant (func-arity (comp-func-byte-func function))) + (let ((comp-curr-allocation-class 'd-default)) + ;; Lambda-lists must stay in the same relocation class of + ;; the object referenced by code to respect uninterned + ;; symbols. + (make-comp-mvar :constant (comp-func-d-lambda-list function))))) (cl-defgeneric comp-emit-for-top-level (form for-late-load) "Emit the limple code for top level FORM.") @@ -1390,8 +1399,8 @@ the annotation emission." 'comp--late-register-subr 'comp--register-subr) (make-comp-mvar :constant name) - (make-comp-mvar :constant (car args)) - (make-comp-mvar :constant (cdr args)) + (car args) + (cdr args) (make-comp-mvar :constant c-name) (make-comp-mvar :constant @@ -1431,8 +1440,8 @@ These are stored in the reloc data array." (puthash (comp-func-byte-func func) (make-comp-mvar :constant nil) (comp-ctxt-lambda-fixups-h comp-ctxt))) - (make-comp-mvar :constant (car args)) - (make-comp-mvar :constant (cdr args)) + (car args) + (cdr args) (make-comp-mvar :constant (comp-func-c-name func)) (make-comp-mvar :constant (let* ((h (comp-ctxt-function-docs comp-ctxt)) commit d3ac3534b45f50769d866c25e795d4ca20572a18 Author: Andrea Corallo Date: Mon Jun 29 17:26:29 2020 +0200 Revert "* src/comp.c (Fcomp__register_subr): Remove code duplication using Fdefalias." This reverts commit 6c7f615ae59b636efe5012f761a25acfd956480d. diff --git a/src/comp.c b/src/comp.c index 28f10bed6d..2464b58dad 100644 --- a/src/comp.c +++ b/src/comp.c @@ -4787,7 +4787,17 @@ DEFUN ("comp--register-subr", Fcomp__register_subr, Scomp__register_subr, Lisp_Object tem = make_subr (SYMBOL_NAME (name), minarg, maxarg, c_name, doc_idx, intspec, comp_u); - Fdefalias (name, tem, Qnil); + + LOADHIST_ATTACH (Fcons (Qdefun, name)); + + { /* Handle automatic advice activation (bug#42038). + See `defalias'. */ + Lisp_Object hook = Fget (name, Qdefalias_fset_function); + if (!NILP (hook)) + call2 (hook, name, tem); + else + Ffset (name, tem); + } return tem; } commit 0ce4bf3ede9be928062abe47675345375e01d3c0 Author: Andrea Corallo Date: Sun Jun 28 20:44:22 2020 +0100 * Do not skip native compilation for leim subfolder during boostrap * lisp/emacs-lisp/comp.el (comp-bootstrap-black-list): Remove "^leim/". diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index e5674ccc95..cde9899d26 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -93,7 +93,7 @@ Skip if any is matching." :group 'comp) (defcustom comp-bootstrap-black-list - '("^leim/") + '() "List of regexps to exclude files from native compilation during bootstrap. Skip if any is matching." :type 'list commit 1dd2c8cd0770040b616803f4b6a4a81ff314ea6a Author: Andrea Corallo Date: Sun Jun 28 20:38:13 2020 +0100 * Enable deferred compilation for dynamic scoped code * src/comp.c (maybe_defer_native_compilation): Trigger for dynamic code and add a comment. diff --git a/src/comp.c b/src/comp.c index 3abcabc893..28f10bed6d 100644 --- a/src/comp.c +++ b/src/comp.c @@ -4411,6 +4411,14 @@ dispose_comp_unit (struct Lisp_Native_Comp_Unit *comp_handle, bool delay) loaded the compiler and its dependencies. */ static Lisp_Object delayed_sources; + +/* Queue an asyncronous compilation for the source file defining + FUNCTION_NAME and perform a late load. + + NOTE: ideally would be nice to move its call simply into Fload but + we need DEFINITION to guard against function redefinition while + async compilation happen. */ + void maybe_defer_native_compilation (Lisp_Object function_name, Lisp_Object definition) @@ -4443,7 +4451,6 @@ maybe_defer_native_compilation (Lisp_Object function_name, || noninteractive || !NILP (Vpurify_flag) || !COMPILEDP (definition) - || !FIXNUMP (AREF (definition, COMPILED_ARGLIST)) || !STRINGP (Vload_true_file_name) || !suffix_p (Vload_true_file_name, ".elc")) return; commit 98196b03c170a148bb5d558bb9df8a923a652ed6 Merge: 6c7f615ae5 e4028d1515 Author: Andrea Corallo Date: Sun Jun 28 15:54:57 2020 +0100 Merge remote-tracking branch 'savannah/master' into uninterned commit 6c7f615ae59b636efe5012f761a25acfd956480d Author: Andrea Corallo Date: Sun Jun 28 15:38:48 2020 +0100 * src/comp.c (Fcomp__register_subr): Remove code duplication using Fdefalias. diff --git a/src/comp.c b/src/comp.c index bb416ecb19..3abcabc893 100644 --- a/src/comp.c +++ b/src/comp.c @@ -4780,17 +4780,7 @@ DEFUN ("comp--register-subr", Fcomp__register_subr, Scomp__register_subr, Lisp_Object tem = make_subr (SYMBOL_NAME (name), minarg, maxarg, c_name, doc_idx, intspec, comp_u); - - LOADHIST_ATTACH (Fcons (Qdefun, name)); - - { /* Handle automatic advice activation (bug#42038). - See `defalias'. */ - Lisp_Object hook = Fget (name, Qdefalias_fset_function); - if (!NILP (hook)) - call2 (hook, name, tem); - else - Ffset (name, tem); - } + Fdefalias (name, tem, Qnil); return tem; } commit 5b8b2982830028303d207d111095e35c90ae6805 Author: Andrea Corallo Date: Sun Jun 28 13:45:49 2020 +0100 Add a test to verify CL macro expansion in dynamic scope * test/src/comp-tests.el (comp-tests-cl-macro-exp): New test. * test/src/comp-test-funcs-dyn.el: Require `cl-lib'. (comp-tests-cl-macro-exp-f): New function. diff --git a/test/src/comp-test-funcs-dyn.el b/test/src/comp-test-funcs-dyn.el index 0e342a39d3..50a72807be 100644 --- a/test/src/comp-test-funcs-dyn.el +++ b/test/src/comp-test-funcs-dyn.el @@ -23,6 +23,8 @@ ;;; Code: +(require 'cl-lib) + (defun comp-tests-ffuncall-callee-dyn-f (a b) (list a b)) @@ -35,6 +37,11 @@ (defun comp-tests-ffuncall-callee-opt-rest-dyn-f (a b &optional c &rest d) (list a b c d)) +(defun comp-tests-cl-macro-exp-f () + (cl-loop for xxx in '(a b) + for yyy = xxx + collect xxx)) + (provide 'comp-test-dyn-funcs) ;;; comp-test-funcs-dyn.el ends here diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 51586d2f9e..fe818960dd 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -574,4 +574,8 @@ https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-03/msg00914.html." (should (equal '(2 . many) (func-arity #'comp-tests-ffuncall-callee-opt-rest-dyn-f)))) +(ert-deftest comp-tests-cl-macro-exp () + "Verify CL macro expansion (bug#42088)." + (should (equal (comp-tests-cl-macro-exp-f) '(a b)))) + ;;; comp-tests.el ends here commit 7f8512765a50858d51805762e88d291fc31b3490 Author: Andrea Corallo Date: Sun Jun 28 13:33:11 2020 +0100 * Setup correctly the printer while dumping objs in native CU (bug#42088) * src/comp.c (emit_static_object): Bind a bunch of special variables to setup `prin1-to-string' as `byte-compile-output-file-form' does. This to preserve uninterned symbols. diff --git a/src/comp.c b/src/comp.c index 6909aefda7..bb416ecb19 100644 --- a/src/comp.c +++ b/src/comp.c @@ -2339,7 +2339,19 @@ emit_static_object (const char *name, Lisp_Object obj) strings cause of this funny bug that will affect all pre gcc10 era gccs: https://gcc.gnu.org/ml/jit/2019-q3/msg00013.html */ + ptrdiff_t count = SPECPDL_INDEX (); + /* Preserve uninterned symbols, this is specifically necessary for + CL macro expansion in dynamic scope code (bug#42088). See + `byte-compile-output-file-form'. */ + specbind (intern_c_string ("print-escape-newlines"), Qt); + specbind (intern_c_string ("print-length"), Qnil); + specbind (intern_c_string ("print-level"), Qnil); + specbind (intern_c_string ("print-quoted"), Qt); + specbind (intern_c_string ("print-gensym"), Qt); + specbind (intern_c_string ("print-circle"), Qt); Lisp_Object str = Fprin1_to_string (obj, Qnil); + unbind_to (count, Qnil); + ptrdiff_t len = SBYTES (str); const char *p = SSDATA (str); commit 0eedb5af0b9f505dda9418323c74e992a40e5585 Merge: 24f68d6bfc 118c07e02e Author: Andrea Corallo Date: Sat Jun 27 21:42:16 2020 +0100 Merge remote-tracking branch 'savannah/master' into HEAD commit 24f68d6bfc83b5514d928853ffd86b97c53e1623 Author: Andrea Corallo Date: Sat Jun 27 20:59:22 2020 +0100 src/comp.c (Fcomp__register_subr): Handle advice activation (bug#42038). diff --git a/src/comp.c b/src/comp.c index 29aa635208..6909aefda7 100644 --- a/src/comp.c +++ b/src/comp.c @@ -4769,9 +4769,17 @@ DEFUN ("comp--register-subr", Fcomp__register_subr, Scomp__register_subr, make_subr (SYMBOL_NAME (name), minarg, maxarg, c_name, doc_idx, intspec, comp_u); - set_symbol_function (name, tem); LOADHIST_ATTACH (Fcons (Qdefun, name)); + { /* Handle automatic advice activation (bug#42038). + See `defalias'. */ + Lisp_Object hook = Fget (name, Qdefalias_fset_function); + if (!NILP (hook)) + call2 (hook, name, tem); + else + Ffset (name, tem); + } + return tem; } commit 801e19d0ba8e048a9faa5d5169ec4183e41b0148 Author: Andrea Corallo Date: Tue Jun 23 00:33:09 2020 +0200 * lisp/gnus/gnus.el (gnus): Fix a check to handle native compilation. diff --git a/lisp/gnus/gnus.el b/lisp/gnus/gnus.el index caeab7f55a..89d5d12054 100644 --- a/lisp/gnus/gnus.el +++ b/lisp/gnus/gnus.el @@ -4126,8 +4126,9 @@ prompt the user for the name of an NNTP server to use." ;; file. (unless (string-match "^Gnus" gnus-version) (load "gnus-load" nil t)) - (unless (byte-code-function-p (symbol-function 'gnus)) - (message "You should byte-compile Gnus") + (unless (or (byte-code-function-p (symbol-function 'gnus)) + (subr-native-elisp-p (symbol-function 'gnus))) + (message "You should compile Gnus") (sit-for 2)) (let ((gnus-action-message-log (list nil))) (gnus-1 arg dont-connect slave) commit c324e02f758550d007ceb55c7168e8734a1d27fa Merge: f0e9fdd1f9 9fe2bdb88a Author: Andrea Corallo Date: Mon Jun 22 00:20:03 2020 +0200 Merge remote-tracking branch 'savahnna/master' into dev commit f0e9fdd1f9a9989b457cbc382e0cf12c161a8e6c Author: Andrea Corallo Date: Sun Jun 21 20:52:52 2020 +0200 Two `load-history' eln related fixes. * src/lread.c (Fload): Fix `load-history' filling for elns non in root lisp-dir. * lisp/startup.el (command-line): Fix `load-history' fixup algorith for eln files. diff --git a/lisp/startup.el b/lisp/startup.el index bff10003f8..e58f27e7eb 100644 --- a/lisp/startup.el +++ b/lisp/startup.el @@ -1061,7 +1061,12 @@ please check its value") (unless (file-readable-p lispdir) (princ (format "Lisp directory %s not readable?" lispdir)) (terpri))) - (setq lisp-dir (file-truename (file-name-directory simple-file-name))) + (setq lisp-dir + (file-truename + (if (string-match "\\.eln\\'" simple-file-name) + (expand-file-name + (concat (file-name-directory simple-file-name) "../")) + (file-name-directory simple-file-name)))) (setq load-history (mapcar (lambda (elt) (if (and (stringp (car elt)) diff --git a/src/lread.c b/src/lread.c index 0530848c2b..f5a7d44a1e 100644 --- a/src/lread.c +++ b/src/lread.c @@ -1506,7 +1506,8 @@ Return t if the file exists and loads successfully. */) specbind (Qcurrent_load_list, Qnil); if (!NILP (Vpurify_flag)) { - Lisp_Object base = parent_directory (Ffile_name_directory (found)); + Lisp_Object base = concat2 (parent_directory (Vinvocation_directory), + build_string ("lisp/")); Lisp_Object offset = Flength (base); hist_file_name = Fsubstring (found, offset, Qnil); } commit 0a70ed9df274f7b262862ddd08a2fd61e2fea42b Author: Andrea Corallo Date: Thu Jun 18 23:21:32 2020 +0200 ;* src/comp.c (define_maybe_gc_or_quit): Fix a comment. diff --git a/src/comp.c b/src/comp.c index 7547a40019..29aa635208 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3590,8 +3590,8 @@ define_maybe_gc_or_quit (void) 9)), /* 9 translates into checking for GC or quit every 512 calls to 'maybe_gc_quit'. This is the smallest value I could find with - no performance impact running elisp-banechmarks. Byte - intepreter uses 256 (see 'exec_byte_code'). */ + no performance impact running elisp-banechmarks and the same + used by the byte intepreter (see 'exec_byte_code'). */ maybe_do_it_block, pass_block); commit 89b6f56de011fa45934800a60bf631fc99ef2a4c Author: Andrea Corallo Date: Thu Jun 18 23:14:06 2020 +0200 * src/comp.c (Fcomp__compile_ctxt_to_file): Confine gcc optim level in [0, 3]. diff --git a/src/comp.c b/src/comp.c index 82a092ad35..7547a40019 100644 --- a/src/comp.c +++ b/src/comp.c @@ -4032,7 +4032,8 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, gcc_jit_context_set_int_option (comp.ctxt, GCC_JIT_INT_OPTION_OPTIMIZATION_LEVEL, - COMP_SPEED); + COMP_SPEED < 0 ? 0 + : (COMP_SPEED > 3 ? 3 : COMP_SPEED)); comp.d_default_idx = CALL1I (comp-data-container-idx, CALL1I (comp-ctxt-d-default, Vcomp_ctxt)); comp.d_impure_idx = commit cfb871add49096f38c5a8ff0882a7e111943ee52 Author: Andrea Corallo Date: Thu Jun 18 23:04:55 2020 +0200 * Handle correctly pure delaration specifier. * lisp/emacs-lisp/comp.el (comp-func): New slot 'pure'. (comp-spill-decl-spec): New function. (comp-spill-speed): Rework to use the later. (comp-spill-lap-function, comp-intern-func-in-ctxt): Spill pure decl value. (comp-function-optimizable-p): Check in the compiler env too if pure. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 3372400a6d..e5674ccc95 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -372,7 +372,9 @@ structure.") (array-h (make-hash-table) :type hash-table :documentation "array idx -> array length.") (speed nil :type number - :documentation "Optimization level (see `comp-speed').")) + :documentation "Optimization level (see `comp-speed').") + (pure nil :type boolean + :documentation "t if declared pure nil otherwise.")) (cl-defstruct (comp-func-l (:include comp-func)) "Lexical scoped function." @@ -549,10 +551,14 @@ instruction." (and (byte-code-function-p f) (fixnump (aref f 0)))) -(defun comp-spill-speed (fuction-name) - "Return the speed for SYMBOL-FUNCTION." - (or (plist-get (cdr (assq fuction-name byte-to-native-plist-environment)) - 'speed) +(defun comp-spill-decl-spec (function-name spec) + "Return the declared specifier SPEC for FUNCTION-NAME." + (plist-get (cdr (assq function-name byte-to-native-plist-environment)) + spec)) + +(defun comp-spill-speed (function-name) + "Return the speed for FUNCTION-NAME." + (or (comp-spill-decl-spec function-name 'speed) comp-speed)) (defun comp-c-func-name (name prefix) @@ -622,7 +628,9 @@ Put PREFIX in front of it." :c-name c-name :doc (documentation f) :int-spec (interactive-form f) - :speed (comp-spill-speed function-name)))) + :speed (comp-spill-speed function-name) + :pure (comp-spill-decl-spec function-name + 'pure)))) (when (byte-code-function-p f) (signal 'native-compiler-error "can't native compile an already bytecompiled function")) @@ -672,7 +680,8 @@ Put PREFIX in front of it." (comp-func-c-name func) c-name (comp-func-lap func) lap (comp-func-frame-size func) (comp-byte-frame-size byte-func) - (comp-func-speed func) (comp-spill-speed name)) + (comp-func-speed func) (comp-spill-speed name) + (comp-func-pure func) (comp-spill-decl-spec name 'pure)) ;; Store the c-name to have it retrivable from ;; `comp-ctxt-top-level-forms'. @@ -1960,7 +1969,12 @@ Here goes everything that can be done not iteratively (read once). (defsubst comp-function-optimizable-p (f args) "Given function F called with ARGS return non nil when optimizable." (when (cl-every #'comp-mvar-const-vld args) - (or (get f 'pure) + (or (when-let ((func (gethash (gethash f + (comp-ctxt-sym-to-c-name-h + comp-ctxt)) + (comp-ctxt-funcs-h comp-ctxt)))) + (comp-func-pure func)) + (get f 'pure) (memq (get f 'byte-optimizer) comp-propagate-classes) (let ((values (mapcar #'comp-mvar-constant args))) (pcase f commit 1179a1c748f7c18b8b82f14608f8f86790814a25 Author: Andrea Corallo Date: Wed Jun 17 22:46:48 2020 +0200 * Add a func-arity test for dynamic functions * test/src/comp-tests.el (comp-tests-dynamic-arity): New test. diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index d6fff8233c..51586d2f9e 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -563,4 +563,15 @@ https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-03/msg00914.html." (should (equal (comp-tests-ffuncall-callee-opt-rest-dyn-f 1 2 3 4) '(1 2 3 (4))))) +(ert-deftest comp-tests-dynamic-arity () + "Test func-arity on dynamic scope functions." + (should (equal '(2 . 2) + (func-arity #'comp-tests-ffuncall-callee-dyn-f))) + (should (equal '(2 . 4) + (func-arity #'comp-tests-ffuncall-callee-opt-dyn-f))) + (should (equal '(2 . many) + (func-arity #'comp-tests-ffuncall-callee-rest-dyn-f))) + (should (equal '(2 . many) + (func-arity #'comp-tests-ffuncall-callee-opt-rest-dyn-f)))) + ;;; comp-tests.el ends here commit 51df0ab6f6dc8085be6140fa9b87e4a124ce5ad9 Author: Andrea Corallo Date: Wed Jun 17 22:17:57 2020 +0200 Do not native compile two functions to allow cc-mode hack * lisp/progmodes/cc-langs.el (c-populate-syntax-table): Declare with speed -1. * lisp/progmodes/cc-bytecomp.el (cc-bytecomp-compiling-or-loading): Declare with speed -1. diff --git a/lisp/progmodes/cc-bytecomp.el b/lisp/progmodes/cc-bytecomp.el index 959261c9eb..5eb8af2534 100644 --- a/lisp/progmodes/cc-bytecomp.el +++ b/lisp/progmodes/cc-bytecomp.el @@ -97,6 +97,8 @@ ;; compilation can trigger loading (various `require' type forms) ;; and loading can trigger compilation (the package manager does ;; this). We walk the lisp stack if necessary. + ;; Never native compile to allow cc-defs.el:2345 hack. + (declare (speed -1)) (cond ((and load-in-progress (boundp 'byte-compile-dest-file) diff --git a/lisp/progmodes/cc-langs.el b/lisp/progmodes/cc-langs.el index dcffc0d31b..3ac4aad90b 100644 --- a/lisp/progmodes/cc-langs.el +++ b/lisp/progmodes/cc-langs.el @@ -337,7 +337,8 @@ the evaluated constant value at compile time." This includes setting \\=' and \" as string delimiters, and setting up the comment syntax to handle both line style \"//\" and block style \"/*\" \"*/\" comments." - + ;; Never native compile to allow cc-mode.el:467 hack. + (declare (speed -1)) (modify-syntax-entry ?_ "_" table) (modify-syntax-entry ?\\ "\\" table) (modify-syntax-entry ?+ "." table) commit 34117dea7736012114e5c20fcf9f328e0658f8b3 Author: Andrea Corallo Date: Mon Jun 15 21:27:00 2020 +0200 Add a test for speed -1 * test/src/comp-tests.el (comp-test-speed--1): New test * test/src/comp-test-funcs.el (comp-test-speed--1-f): New function. diff --git a/test/src/comp-test-funcs.el b/test/src/comp-test-funcs.el index 5e04be4459..168819b17d 100644 --- a/test/src/comp-test-funcs.el +++ b/test/src/comp-test-funcs.el @@ -286,6 +286,10 @@ (defun comp-test-40187-2-f () 'bar) +(defun comp-test-speed--1-f () + (declare (speed -1)) + 3) + ;;;;;;;;;;;;;;;;;;;; ;; Tromey's tests ;; diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index ee96d5656e..d6fff8233c 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -358,6 +358,11 @@ https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-03/msg00914.html." (should (eq (comp-test-40187-1-f) 'foo)) (should (eq (comp-test-40187-2-f) 'bar))) +(ert-deftest comp-test-speed--1 () + "Check that at speed -1 we do not native compile." + (should (= (comp-test-speed--1-f) 3)) + (should-not (subr-native-elisp-p (symbol-function #'comp-test-speed--1-f)))) + ;;;;;;;;;;;;;;;;;;;;; ;; Tromey's tests. ;; commit decced8337278e3e21e9926819edd7eab003587a Author: Andrea Corallo Date: Mon Jun 15 20:26:00 2020 +0200 Allow per function speed declaration * src/comp.c (COMP_SPEED): Rename. (comp_t): Add 'func_speed' field. (emit_mvar_lval, compile_function): Update for per function speed. (Fcomp__compile_ctxt_to_file): COMP_SPEED renamed. * lisp/emacs-lisp/comp.el (comp-speed): Doc update. (comp-func): New 'speed' slot. (comp-spill-speed): New function. (comp-spill-lap-function, comp-intern-func-in-ctxt): Fill 'speed' slot. (comp-spill-lap-function): Gate -1 speed functions for native compilation and emit bytecode instead. (comp-spill-lap): Close over `byte-to-native-plist-environment'. (comp-latch-make-fill): Update for per function speed. (comp-limplify-top-level): Fill speed. (comp-propagate1, comp-call-optim-form-call, comp-call-optim) (comp-dead-code, comp-tco, comp-remove-type-hints): Update for per function speed. diff --git a/lisp/emacs-lisp/byte-run.el b/lisp/emacs-lisp/byte-run.el index 88e21b73fe..4c1dce264a 100644 --- a/lisp/emacs-lisp/byte-run.el +++ b/lisp/emacs-lisp/byte-run.el @@ -143,6 +143,11 @@ The return value of this function is not used." (list 'function-put (list 'quote f) ''lisp-indent-function (list 'quote val)))) +(defalias 'byte-run--set-speed + #'(lambda (f _args val) + (list 'function-put (list 'quote f) + ''speed (list 'quote val)))) + ;; Add any new entries to info node `(elisp)Declare Form'. (defvar defun-declarations-alist (list @@ -159,7 +164,8 @@ This may shift errors from run-time to compile-time.") If `error-free', drop calls even if `byte-compile-delete-errors' is nil.") (list 'compiler-macro #'byte-run--set-compiler-macro) (list 'doc-string #'byte-run--set-doc-string) - (list 'indent #'byte-run--set-indent)) + (list 'indent #'byte-run--set-indent) + (list 'speed #'byte-run--set-speed)) "List associating function properties to their macro expansion. Each element of the list takes the form (PROP FUN) where FUN is a function. For each (PROP . VALUES) in a function's declaration, diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index c7d2344dbd..7a56aa2df2 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -601,6 +601,8 @@ Each element is (INDEX . VALUE)") "List of top level forms.") (defvar byte-to-native-output-file nil "Temporary file containing the byte-compilation output.") +(defvar byte-to-native-plist-environment nil + "To spill `overriding-plist-environment'.") ;;; The byte codes; this information is duplicated in bytecomp.c @@ -1740,7 +1742,11 @@ extra args." ;; byte-compile-generate-emacs19-bytecodes) (byte-compile-warnings byte-compile-warnings) ) - ,@body)) + (prog1 + (progn ,@body) + (when byte-native-compiling + (setq byte-to-native-plist-environment + overriding-plist-environment))))) (defmacro displaying-byte-compile-warnings (&rest body) (declare (debug t)) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 928fa516ed..3372400a6d 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -49,10 +49,11 @@ the native compiled one." :group 'comp) (defcustom comp-speed 2 - "Compiler optimization level. From 0 to 3. -- 0 no optimizations are performed, compile time is favored. + "Compiler optimization level. From -1 to 3. +- -1 functions are kept in bytecode form and no native compilation is performed. +- 0 native compilation is performed with no optimizations. - 1 lite optimizations. -- 2 heavy optimizations. +- 2 max optimization level fully adherent to the language semantic. - 3 max optimization level, to be used only when necessary. Warning: the compiler is free to perform dangerous optimizations." :type 'number @@ -369,7 +370,9 @@ structure.") (has-non-local nil :type boolean :documentation "t if non local jumps are present.") (array-h (make-hash-table) :type hash-table - :documentation "array idx -> array length.")) + :documentation "array idx -> array length.") + (speed nil :type number + :documentation "Optimization level (see `comp-speed').")) (cl-defstruct (comp-func-l (:include comp-func)) "Lexical scoped function." @@ -546,6 +549,12 @@ instruction." (and (byte-code-function-p f) (fixnump (aref f 0)))) +(defun comp-spill-speed (fuction-name) + "Return the speed for SYMBOL-FUNCTION." + (or (plist-get (cdr (assq fuction-name byte-to-native-plist-environment)) + 'speed) + comp-speed)) + (defun comp-c-func-name (name prefix) "Given NAME return a name suitable for the native code. Put PREFIX in front of it." @@ -612,7 +621,8 @@ Put PREFIX in front of it." (func (make-comp-func-l :name function-name :c-name c-name :doc (documentation f) - :int-spec (interactive-form f)))) + :int-spec (interactive-form f) + :speed (comp-spill-speed function-name)))) (when (byte-code-function-p f) (signal 'native-compiler-error "can't native compile an already bytecompiled function")) @@ -661,7 +671,8 @@ Put PREFIX in front of it." (comp-func-int-spec func) (interactive-form 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)) + (comp-func-frame-size func) (comp-byte-frame-size byte-func) + (comp-func-speed func) (comp-spill-speed name)) ;; Store the c-name to have it retrivable from ;; `comp-ctxt-top-level-forms'. @@ -681,7 +692,21 @@ Put PREFIX in front of it." (unless byte-to-native-top-level-forms (signal 'native-compiler-error-empty-byte filename)) (setf (comp-ctxt-top-level-forms comp-ctxt) - (reverse byte-to-native-top-level-forms)) + (cl-loop + for form in (reverse byte-to-native-top-level-forms) + collect + (if (and (byte-to-native-func-def-p form) + (eq -1 + (comp-spill-speed (byte-to-native-func-def-name form)))) + (let ((byte-code (byte-to-native-func-def-byte-func form))) + (remhash byte-code byte-to-native-lambdas-h) + (make-byte-to-native-top-level + :form `(defalias + ',(byte-to-native-func-def-name form) + ,byte-code + nil) + :lexical (comp-lex-byte-func-p byte-code))) + form))) (maphash #'comp-intern-func-in-ctxt byte-to-native-lambdas-h)) (defun comp-spill-lap (input) @@ -690,7 +715,8 @@ If INPUT is a symbol this is the function-name to be compiled. If INPUT is a string this is the file path to be compiled." (let ((byte-native-compiling t) (byte-to-native-lambdas-h (make-hash-table :test #'eq)) - (byte-to-native-top-level-forms ())) + (byte-to-native-top-level-forms ()) + (byte-to-native-plist-environment ())) (comp-spill-lap-function input))) @@ -867,7 +893,7 @@ Return the created latch" (curr-bb (comp-limplify-curr-block comp-pass))) ;; See `comp-make-curr-block'. (setf (comp-limplify-curr-block comp-pass) latch) - (when (< comp-speed 3) + (when (< (comp-func-speed comp-func) 3) ;; At speed 3 the programmer is responsible to manually ;; place `comp-maybe-gc-or-quit'. (comp-emit '(call comp-maybe-gc-or-quit))) @@ -1429,7 +1455,8 @@ into the C code forwarding the compilation unit." "late_top_level_run" "top_level_run") :args (make-comp-args :min 1 :max 1) - :frame-size 1)) + :frame-size 1 + :speed comp-speed)) (comp-func func) (comp-pass (make-comp-limplify :curr-block (make--comp-block-lap -1 0 'top-level) @@ -2029,18 +2056,18 @@ Return t if something was changed." (defun comp-propagate1 (backward) (comp-ssa) - (when (>= comp-speed 2) - (maphash (lambda (_ f) - ;; FIXME remove the following condition when tested. - (unless (comp-func-has-non-local f) - (let ((comp-func f)) - (comp-propagate-prologue backward) - (cl-loop - for i from 1 - while (comp-propagate*) - finally (comp-log (format "Propagation run %d times\n" i) 2)) - (comp-log-func comp-func 3)))) - (comp-ctxt-funcs-h comp-ctxt)))) + (maphash (lambda (_ f) + (when (and (>= (comp-func-speed f) 2) + ;; FIXME remove the following condition when tested. + (not (comp-func-has-non-local f))) + (let ((comp-func f)) + (comp-propagate-prologue backward) + (cl-loop + for i from 1 + while (comp-propagate*) + finally (comp-log (format "Propagation run %d times\n" i) 2)) + (comp-log-func comp-func 3)))) + (comp-ctxt-funcs-h comp-ctxt))) (defun comp-propagate (_) "Forward propagate types and consts within the lattice." @@ -2110,9 +2137,9 @@ FUNCTION can be a function-name or byte compiled function." ;; Intra compilation unit procedure call optimization. ;; Attention speed 3 triggers this for non self calls too!! ((and comp-func-callee - (or (and (>= comp-speed 3) + (or (and (>= (comp-func-speed comp-func) 3) (comp-func-unique-in-cu-p callee)) - (and (>= comp-speed 2) + (and (>= (comp-func-speed comp-func) 2) ;; Anonymous lambdas can't be redefined so are ;; always safe to optimize. (byte-code-function-p callee)))) @@ -2145,12 +2172,12 @@ FUNCTION can be a function-name or byte compiled function." (defun comp-call-optim (_) "Try to optimize out funcall trampoline usage when possible." - (when (>= comp-speed 2) - (maphash (lambda (_ f) + (maphash (lambda (_ f) + (when (and (>= (comp-func-speed f) 2) + (comp-func-l-p f)) (let ((comp-func f)) - (when (comp-func-l-p f) - (comp-call-optim-func)))) - (comp-ctxt-funcs-h comp-ctxt)))) + (comp-call-optim-func)))) + (comp-ctxt-funcs-h comp-ctxt))) ;;; Dead code elimination pass specific code. @@ -2209,17 +2236,17 @@ Return the list of m-var ids nuked." (defun comp-dead-code (_) "Dead code elimination." - (when (>= comp-speed 2) - (maphash (lambda (_ f) - (let ((comp-func f)) - ;; FIXME remove the following condition when tested. - (unless (comp-func-has-non-local comp-func) - (cl-loop - for i from 1 - while (comp-dead-assignments-func) - finally (comp-log (format "dead code rm run %d times\n" i) 2) - (comp-log-func comp-func 3))))) - (comp-ctxt-funcs-h comp-ctxt)))) + (maphash (lambda (_ f) + (when (and (>= (comp-func-speed f) 2) + ;; FIXME remove the following condition when tested. + (not (comp-func-has-non-local f))) + (cl-loop + for comp-func = f + for i from 1 + while (comp-dead-assignments-func) + finally (comp-log (format "dead code rm run %d times\n" i) 2) + (comp-log-func comp-func 3)))) + (comp-ctxt-funcs-h comp-ctxt))) ;;; Tail Call Optimization pass specific code. @@ -2252,14 +2279,14 @@ Return the list of m-var ids nuked." (defun comp-tco (_) "Simple peephole pass performing self TCO." - (when (>= comp-speed 3) - (maphash (lambda (_ f) + (maphash (lambda (_ f) + (when (and (>= (comp-func-speed f) 3) + (comp-func-l-p f) + (not (comp-func-has-non-local f))) (let ((comp-func f)) - (when (and (comp-func-l-p f) - (not (comp-func-has-non-local comp-func))) - (comp-tco-func) - (comp-log-func comp-func 3)))) - (comp-ctxt-funcs-h comp-ctxt)))) + (comp-tco-func) + (comp-log-func comp-func 3)))) + (comp-ctxt-funcs-h comp-ctxt))) ;;; Type hint removal pass specific code. @@ -2279,12 +2306,12 @@ These are substituted with a normal 'set' op." (defun comp-remove-type-hints (_) "Dead code elimination." - (when (>= comp-speed 2) - (maphash (lambda (_ f) + (maphash (lambda (_ f) + (when (>= (comp-func-speed f) 2) (let ((comp-func f)) (comp-remove-type-hints-func) - (comp-log-func comp-func 3))) - (comp-ctxt-funcs-h comp-ctxt)))) + (comp-log-func comp-func 3)))) + (comp-ctxt-funcs-h comp-ctxt))) ;;; Final pass specific code. diff --git a/src/comp.c b/src/comp.c index 781ad3e08e..82a092ad35 100644 --- a/src/comp.c +++ b/src/comp.c @@ -411,7 +411,7 @@ load_gccjit_if_necessary (bool mandatory) #define TEXT_FDOC_SYM "text_data_fdoc" -#define SPEED XFIXNUM (Fsymbol_value (Qcomp_speed)) +#define COMP_SPEED XFIXNUM (Fsymbol_value (Qcomp_speed)) #define COMP_DEBUG XFIXNUM (Fsymbol_value (Qcomp_debug)) #define STR_VALUE(s) #s @@ -536,6 +536,7 @@ typedef struct { size_t cast_union_field_biggest_type; gcc_jit_function *func; /* Current function being compiled. */ bool func_has_non_local; /* From comp-func has-non-local slot. */ + EMACS_INT func_speed; /* From comp-func speed slot. */ gcc_jit_lvalue **f_frame; /* "Floating" frame for the current function. */ gcc_jit_block *block; /* Current basic block being compiled. */ gcc_jit_lvalue *scratch; /* Used as scratch slot for some code sequence (switch). */ @@ -734,7 +735,7 @@ emit_mvar_lval (Lisp_Object mvar) EMACS_INT arr_idx = XFIXNUM (CALL1I (comp-mvar-array-idx, mvar)); EMACS_INT slot_n = XFIXNUM (mvar_slot); - if (comp.func_has_non_local || (SPEED < 2)) + if (comp.func_has_non_local || (comp.func_speed < 2)) return comp.arrays[arr_idx][slot_n]; else { @@ -3736,6 +3737,7 @@ compile_function (Lisp_Object func) comp.exported_funcs_h, Qnil)); comp.func_has_non_local = !NILP (CALL1I (comp-func-has-non-local, func)); + comp.func_speed = XFIXNUM (CALL1I (comp-func-speed, func)); struct Lisp_Hash_Table *array_h = XHASH_TABLE (CALL1I (comp-func-array-h, func)); @@ -3775,7 +3777,7 @@ compile_function (Lisp_Object func) - Allow gcc to trigger other optimizations that are prevented by memory referencing. */ - if (SPEED >= 2) + if (comp.func_speed >= 2) { comp.f_frame = SAFE_ALLOCA (frame_size * sizeof (*comp.f_frame)); for (ptrdiff_t i = 0; i < frame_size; ++i) @@ -4030,7 +4032,7 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, gcc_jit_context_set_int_option (comp.ctxt, GCC_JIT_INT_OPTION_OPTIMIZATION_LEVEL, - SPEED); + COMP_SPEED); comp.d_default_idx = CALL1I (comp-data-container-idx, CALL1I (comp-ctxt-d-default, Vcomp_ctxt)); comp.d_impure_idx = commit 29b2a08c36554ec26f8f3c51da2a2a26b13bfe8f Author: Andrea Corallo Date: Tue Jun 2 11:08:50 2020 +0100 Execute top level forms in the right lex/dyn scope. * lisp/emacs-lisp/bytecomp.el (byte-to-native-top-level): Add 'lexical' slot. (byte-compile-output-file-form): Update for new slot. (byte-compile-file-form-defmumble): Capture scope. * lisp/emacs-lisp/comp.el (comp-emit-for-top-level): Specify execution scope. diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 9e39b8f78a..c7d2344dbd 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -585,7 +585,7 @@ Each element is (INDEX . VALUE)") name c-name byte-func) (cl-defstruct byte-to-native-top-level "All other top-level forms." - form) + form lexical) (defvar byte-native-compiling nil "Non nil while native compiling.") @@ -2248,7 +2248,7 @@ Call from the source buffer." ;; it here. (when byte-native-compiling ;; Spill output for the native compiler here - (push (make-byte-to-native-top-level :form form) + (push (make-byte-to-native-top-level :form form :lexical lexical-binding) byte-to-native-top-level-forms)) (let ((print-escape-newlines t) (print-length nil) @@ -2707,7 +2707,8 @@ not to take responsibility for the actual compilation of the code." ;; Spill output for the native compiler here. (push (if macro (make-byte-to-native-top-level - :form `(defalias ',name '(macro . ,code) nil)) + :form `(defalias ',name '(macro . ,code) nil) + :lexical lexical-binding) (make-byte-to-native-func-def :name name :byte-func code)) byte-to-native-top-level-forms)) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index e7bd069072..928fa516ed 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1373,11 +1373,13 @@ the annotation emission." (cl-defmethod comp-emit-for-top-level ((form byte-to-native-top-level) for-late-load) (unless for-late-load - (let ((form (byte-to-native-top-level-form form))) - (comp-emit (comp-call 'eval - (let ((comp-curr-allocation-class 'd-impure)) - (make-comp-mvar :constant form)) - (make-comp-mvar :constant t)))))) + (comp-emit + (comp-call 'eval + (let ((comp-curr-allocation-class 'd-impure)) + (make-comp-mvar :constant + (byte-to-native-top-level-form form))) + (make-comp-mvar :constant + (byte-to-native-top-level-lexical form)))))) (defun comp-emit-lambda-for-top-level (func) "Emit the creation of subrs for lambda FUNC. commit 47ab6c237e703cf4b5bbcd3c301e324e0deb1173 Author: Andrea Corallo Date: Tue Dec 10 12:55:34 2019 +0100 Add some testing for dynamic scope * test/src/comp-test-funcs-dyn.el: New file. * test/src/comp-tests.el (comp-tests-dynamic-ffuncall): Add new tests. diff --git a/test/src/comp-test-funcs-dyn.el b/test/src/comp-test-funcs-dyn.el new file mode 100644 index 0000000000..0e342a39d3 --- /dev/null +++ b/test/src/comp-test-funcs-dyn.el @@ -0,0 +1,40 @@ +;;; comp-test-funcs.el --- compilation unit tested by comp-tests.el -*- lexical-binding: nil; -*- + +;; Copyright (C) 2020 Free Software Foundation, Inc. + +;; Author: Andrea Corallo + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;;; Code: + +(defun comp-tests-ffuncall-callee-dyn-f (a b) + (list a b)) + +(defun comp-tests-ffuncall-callee-opt-dyn-f (a b &optional c d) + (list a b c d)) + +(defun comp-tests-ffuncall-callee-rest-dyn-f (a b &rest c) + (list a b c)) + +(defun comp-tests-ffuncall-callee-opt-rest-dyn-f (a b &optional c &rest d) + (list a b c d)) + +(provide 'comp-test-dyn-funcs) + +;;; comp-test-funcs-dyn.el ends here diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 3e40dba10b..ee96d5656e 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -34,8 +34,14 @@ (defconst comp-test-src (concat comp-test-directory "comp-test-funcs.el")) -(message "Compiling %s" comp-test-src) +(defconst comp-test-dyn-src + (concat comp-test-directory "comp-test-funcs-dyn.el")) + +(message "Compiling tests...") (load (native-compile comp-test-src)) +(load (native-compile comp-test-dyn-src)) + + (ert-deftest comp-tests-bootstrap () "Compile the compiler and load it to compile it-self. @@ -353,9 +359,9 @@ https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-03/msg00914.html." (should (eq (comp-test-40187-2-f) 'bar))) -;;;;;;;;;;;;;;;;;;;; -;; Tromey's tests ;; -;;;;;;;;;;;;;;;;;;;; +;;;;;;;;;;;;;;;;;;;;; +;; Tromey's tests. ;; +;;;;;;;;;;;;;;;;;;;;; (ert-deftest comp-consp () (should-not (comp-test-consp 23)) @@ -520,4 +526,36 @@ https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-03/msg00914.html." nil)) (should (eq comp-test-up-val 999))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Tests for dynamic scope. ;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(ert-deftest comp-tests-dynamic-ffuncall () + "Test calling convention for dynamic binding." + + (should (equal (comp-tests-ffuncall-callee-dyn-f 1 2) + '(1 2))) + + (should (equal (comp-tests-ffuncall-callee-opt-dyn-f 1 2 3 4) + '(1 2 3 4))) + (should (equal (comp-tests-ffuncall-callee-opt-dyn-f 1 2 3) + '(1 2 3 nil))) + (should (equal (comp-tests-ffuncall-callee-opt-dyn-f 1 2) + '(1 2 nil nil))) + + (should (equal (comp-tests-ffuncall-callee-rest-dyn-f 1 2) + '(1 2 nil))) + (should (equal (comp-tests-ffuncall-callee-rest-dyn-f 1 2 3) + '(1 2 (3)))) + (should (equal (comp-tests-ffuncall-callee-rest-dyn-f 1 2 3 4) + '(1 2 (3 4)))) + + (should (equal (comp-tests-ffuncall-callee-opt-rest-dyn-f 1 2) + '(1 2 nil nil))) + (should (equal (comp-tests-ffuncall-callee-opt-rest-dyn-f 1 2 3) + '(1 2 3 nil))) + (should (equal (comp-tests-ffuncall-callee-opt-rest-dyn-f 1 2 3 4) + '(1 2 3 (4))))) + ;;; comp-tests.el ends here commit c37b5446d1f8e567f97f5708008b14a80b6c6d65 Author: Andrea Corallo Date: Mon Jun 1 12:47:29 2020 +0100 Add native compiler dynamic scope support Add an initial implementation to support dynamic scope. Arg parsing/binding it's done using the existing code in use for bytecode (no ad-hoc code is synthetized for that). * src/lisp.h (struct Lisp_Subr): Add lambda_list field. (SUBR_NATIVE_COMPILED_DYNP): New inliner. * src/alloc.c (mark_object): Update for Add lambda_list field. * src/eval.c (eval_sub, Ffuncall, funcall_lambda): Handle native compiled dynamic scope * src/comp.c (declare_lex_function): Rename from declare_function and rework. (declare_function): New function. (make_subr): Handle daynamic scope * src/pdumper.c (dump_subr): Update for lambda_list field. * lisp/emacs-lisp/comp.el (comp-func): Remove args slot. (comp-func-l, comp-func-d): New classes deriving from `comp-func'. (comp-spill-lap-function): Rework. (comp-prepare-args-for-top-level): New function. (comp-emit-for-top-level, comp-emit-lambda-for-top-level): Make use of `comp-prepare-args-for-top-level'. (comp-limplify-top-level): Use `comp-func-l'. (comp-limplify-function): Emit arg prologue only for dynamic scoped functions. (comp-call-optim-form-call): Use `comp-func-l'. (comp-call-optim, comp-tco): Do not optimize dynamic scoped code. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 5027d1da08..e7bd069072 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -354,7 +354,6 @@ into it.") :documentation "SSA status either: 'nil', 'dirty' or 't'. Once in SSA form this *must* be set to 'dirty' every time the topology of the CFG is mutated by a pass.") - (args nil :type comp-args-base) (frame-size nil :type number) (blocks (make-hash-table) :type hash-table :documentation "Key is the basic block symbol value is a comp-block @@ -372,6 +371,16 @@ structure.") (array-h (make-hash-table) :type hash-table :documentation "array idx -> array length.")) +(cl-defstruct (comp-func-l (:include comp-func)) + "Lexical scoped function." + (args nil :type comp-args-base + :documentation "Argument specification of the function")) + +(cl-defstruct (comp-func-d (:include comp-func)) + "Dynamic scoped function." + (lambda-list nil :type list + :documentation "Original lambda-list.")) + (cl-defstruct (comp-mvar (:constructor make--comp-mvar)) "A meta-variable being a slot in the meta-stack." (id nil :type (or null number) @@ -600,10 +609,10 @@ Put PREFIX in front of it." "Byte compile FUNCTION-NAME spilling data from the byte compiler." (let* ((f (symbol-function function-name)) (c-name (comp-c-func-name function-name "F")) - (func (make-comp-func :name function-name - :c-name c-name - :doc (documentation f) - :int-spec (interactive-form f)))) + (func (make-comp-func-l :name function-name + :c-name c-name + :doc (documentation f) + :int-spec (interactive-form f)))) (when (byte-code-function-p f) (signal 'native-compiler-error "can't native compile an already bytecompiled function")) @@ -615,7 +624,7 @@ Put PREFIX in front of it." (cl-assert lap) (comp-log lap 2) (let ((arg-list (aref (comp-func-byte-func func) 0))) - (setf (comp-func-args func) + (setf (comp-func-l-args func) (comp-decrypt-arg-list arg-list function-name) (comp-func-lap func) lap @@ -631,8 +640,7 @@ Put PREFIX in front of it." (defun comp-intern-func-in-ctxt (_ obj) "Given OBJ of type `byte-to-native-lambda' create a function in `comp-ctxt'." (when-let ((byte-func (byte-to-native-lambda-byte-func obj))) - (let* ((byte-func (byte-to-native-lambda-byte-func obj)) - (lap (byte-to-native-lambda-lap obj)) + (let* ((lap (byte-to-native-lambda-lap obj)) (top-l-form (cl-loop for form in (comp-ctxt-top-level-forms comp-ctxt) when (and (byte-to-native-func-def-p form) @@ -640,31 +648,32 @@ Put PREFIX in front of it." byte-func)) return form)) (name (when top-l-form - (byte-to-native-func-def-name top-l-form)))) - ;; Do not refuse to compile if a dynamic byte-compiled lambda - ;; leaks here (advice). - (when (or name (comp-lex-byte-func-p byte-func)) - (let* ((c-name (comp-c-func-name (or name "anonymous-lambda") "F")) - (func (make-comp-func :name name - :byte-func byte-func - :doc (documentation byte-func) - :int-spec (interactive-form byte-func) - :c-name c-name - :args (comp-decrypt-arg-list (aref byte-func 0) - name) - :lap lap - :frame-size (comp-byte-frame-size byte-func)))) - ;; Store the c-name to have it retrivable from - ;; `comp-ctxt-top-level-forms'. - (when top-l-form - (setf (byte-to-native-func-def-c-name top-l-form) c-name)) - (unless name - (puthash byte-func func (comp-ctxt-byte-func-to-func-h comp-ctxt))) - ;; Create the default array. - (puthash 0 (comp-func-frame-size func) (comp-func-array-h func)) - (comp-add-func-to-ctxt func) - (comp-log (format "Function %s:\n" name) 1) - (comp-log lap 1)))))) + (byte-to-native-func-def-name top-l-form))) + (c-name (comp-c-func-name (or name "anonymous-lambda") "F")) + (func (if (comp-lex-byte-func-p byte-func) + (make-comp-func-l + :args (comp-decrypt-arg-list (aref byte-func 0) + name)) + (make-comp-func-d :lambda-list (aref byte-func 0))))) + (setf (comp-func-name func) name + (comp-func-byte-func func) byte-func + (comp-func-doc func) (documentation byte-func) + (comp-func-int-spec func) (interactive-form 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)) + + ;; Store the c-name to have it retrivable from + ;; `comp-ctxt-top-level-forms'. + (when top-l-form + (setf (byte-to-native-func-def-c-name top-l-form) c-name)) + (unless name + (puthash byte-func func (comp-ctxt-byte-func-to-func-h comp-ctxt))) + ;; Create the default array. + (puthash 0 (comp-func-frame-size func) (comp-func-array-h func)) + (comp-add-func-to-ctxt func) + (comp-log (format "Function %s:\n" name) 1) + (comp-log lap 1)))) (cl-defgeneric comp-spill-lap-function ((filename string)) "Byte compile FILENAME spilling data from the byte compiler." @@ -1321,6 +1330,17 @@ the annotation emission." (comp-log-func func 2) func) +(defun comp-prepare-args-for-top-level (function) + "Given FUNCTION return the two args arguments for comp--register-..." + (if (comp-func-l-p function) + (let ((args (comp-func-l-args function))) + (cons (comp-args-base-min args) + (if (comp-args-p args) + (comp-args-max args) + 'many))) + (cons (func-arity (comp-func-byte-func function)) + (comp-func-d-lambda-list function)))) + (cl-defgeneric comp-emit-for-top-level (form for-late-load) "Emit the limple code for top level FORM.") @@ -1329,16 +1349,14 @@ the annotation emission." (let* ((name (byte-to-native-func-def-name form)) (c-name (byte-to-native-func-def-c-name form)) (f (gethash c-name (comp-ctxt-funcs-h comp-ctxt))) - (args (comp-func-args f))) + (args (comp-prepare-args-for-top-level f))) (cl-assert (and name f)) (comp-emit (comp-call (if for-late-load 'comp--late-register-subr 'comp--register-subr) (make-comp-mvar :constant name) - (make-comp-mvar :constant (comp-args-base-min args)) - (make-comp-mvar :constant (if (comp-args-p args) - (comp-args-max args) - 'many)) + (make-comp-mvar :constant (car args)) + (make-comp-mvar :constant (cdr args)) (make-comp-mvar :constant c-name) (make-comp-mvar :constant @@ -1364,7 +1382,7 @@ the annotation emission." (defun comp-emit-lambda-for-top-level (func) "Emit the creation of subrs for lambda FUNC. These are stored in the reloc data array." - (let ((args (comp-func-args func))) + (let ((args (comp-prepare-args-for-top-level func))) (let ((comp-curr-allocation-class 'd-impure)) (comp-add-const-to-relocs (comp-func-byte-func func))) (comp-emit @@ -1376,10 +1394,8 @@ These are stored in the reloc data array." (puthash (comp-func-byte-func func) (make-comp-mvar :constant nil) (comp-ctxt-lambda-fixups-h comp-ctxt))) - (make-comp-mvar :constant (comp-args-base-min args)) - (make-comp-mvar :constant (if (comp-args-p args) - (comp-args-max args) - 'many)) + (make-comp-mvar :constant (car args)) + (make-comp-mvar :constant (cdr args)) (make-comp-mvar :constant (comp-func-c-name func)) (make-comp-mvar :constant (let* ((h (comp-ctxt-function-docs comp-ctxt)) @@ -1404,14 +1420,14 @@ into the C code forwarding the compilation unit." ;; reasons to be execute ever again. Therefore all objects can be ;; just ephemeral. (let* ((comp-curr-allocation-class 'd-ephemeral) - (func (make-comp-func :name (if for-late-load - 'late-top-level-run - 'top-level-run) - :c-name (if for-late-load - "late_top_level_run" - "top_level_run") - :args (make-comp-args :min 1 :max 1) - :frame-size 1)) + (func (make-comp-func-l :name (if for-late-load + 'late-top-level-run + 'top-level-run) + :c-name (if for-late-load + "late_top_level_run" + "top_level_run") + :args (make-comp-args :min 1 :max 1) + :frame-size 1)) (comp-func func) (comp-pass (make-comp-limplify :curr-block (make--comp-block-lap -1 0 'top-level) @@ -1475,20 +1491,22 @@ into the C code forwarding the compilation unit." (let* ((frame-size (comp-func-frame-size func)) (comp-func func) (comp-pass (make-comp-limplify - :frame (comp-new-frame frame-size))) - (args (comp-func-args func))) + :frame (comp-new-frame frame-size)))) (comp-fill-label-h) ;; Prologue (comp-make-curr-block 'entry (comp-sp)) (comp-emit-annotation (concat "Lisp function: " (symbol-name (comp-func-name func)))) - (if (comp-args-p args) - (cl-loop for i below (comp-args-max args) - do (cl-incf (comp-sp)) - (comp-emit `(set-par-to-local ,(comp-slot) ,i))) - (comp-emit-narg-prologue (comp-args-base-min args) - (comp-nargs-nonrest args) - (comp-nargs-rest args))) + ;; Dynamic functions have parameters bound by the trampoline. + (when (comp-func-l-p func) + (let ((args (comp-func-l-args func))) + (if (comp-args-p args) + (cl-loop for i below (comp-args-max args) + do (cl-incf (comp-sp)) + (comp-emit `(set-par-to-local ,(comp-slot) ,i))) + (comp-emit-narg-prologue (comp-args-base-min args) + (comp-nargs-nonrest args) + (comp-nargs-rest args))))) (comp-emit '(jump bb_0)) ;; Body (comp-bb-maybe-add 0 (comp-sp)) @@ -2096,7 +2114,7 @@ FUNCTION can be a function-name or byte compiled function." ;; Anonymous lambdas can't be redefined so are ;; always safe to optimize. (byte-code-function-p callee)))) - (let* ((func-args (comp-func-args comp-func-callee)) + (let* ((func-args (comp-func-l-args comp-func-callee)) (nargs (comp-nargs-p func-args)) (call-type (if nargs 'direct-callref 'direct-call)) (args (if (eq call-type 'direct-callref) @@ -2128,7 +2146,8 @@ FUNCTION can be a function-name or byte compiled function." (when (>= comp-speed 2) (maphash (lambda (_ f) (let ((comp-func f)) - (comp-call-optim-func))) + (when (comp-func-l-p f) + (comp-call-optim-func)))) (comp-ctxt-funcs-h comp-ctxt)))) @@ -2234,7 +2253,8 @@ Return the list of m-var ids nuked." (when (>= comp-speed 3) (maphash (lambda (_ f) (let ((comp-func f)) - (unless (comp-func-has-non-local comp-func) + (when (and (comp-func-l-p f) + (not (comp-func-has-non-local comp-func))) (comp-tco-func) (comp-log-func comp-func 3)))) (comp-ctxt-funcs-h comp-ctxt)))) diff --git a/src/alloc.c b/src/alloc.c index 42a53276bc..a31b4a045e 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -6723,6 +6723,7 @@ mark_object (Lisp_Object arg) struct Lisp_Subr *subr = XSUBR (obj); mark_object (subr->native_intspec); mark_object (subr->native_comp_u[0]); + mark_object (subr->lambda_list[0]); } break; diff --git a/src/comp.c b/src/comp.c index 24d69b2b1e..781ad3e08e 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3655,14 +3655,12 @@ define_bool_to_lisp_obj (void) emit_lisp_obj_rval (Qnil)); } -/* Declare a function being compiled and add it to comp.exported_funcs_h. */ - -static void -declare_function (Lisp_Object func) +static gcc_jit_function * +declare_lex_function (Lisp_Object func) { - gcc_jit_function *gcc_func; + gcc_jit_function *res; char *c_name = SSDATA (CALL1I (comp-func-c-name, func)); - Lisp_Object args = CALL1I (comp-func-args, func); + Lisp_Object args = CALL1I (comp-func-l-args, func); bool nargs = !NILP (CALL1I (comp-nargs-p, args)); USE_SAFE_ALLOCA; @@ -3673,23 +3671,23 @@ declare_function (Lisp_Object func) for (ptrdiff_t i = 0; i < max_args; i++) type[i] = comp.lisp_obj_type; - gcc_jit_param **param = SAFE_ALLOCA (max_args * sizeof (*param)); + gcc_jit_param **params = SAFE_ALLOCA (max_args * sizeof (*params)); for (int i = 0; i < max_args; ++i) - param[i] = gcc_jit_context_new_param (comp.ctxt, + params[i] = gcc_jit_context_new_param (comp.ctxt, NULL, type[i], format_string ("par_%d", i)); - gcc_func = gcc_jit_context_new_function (comp.ctxt, NULL, - GCC_JIT_FUNCTION_EXPORTED, - comp.lisp_obj_type, - c_name, - max_args, - param, - 0); + res = gcc_jit_context_new_function (comp.ctxt, NULL, + GCC_JIT_FUNCTION_EXPORTED, + comp.lisp_obj_type, + c_name, + max_args, + params, + 0); } else { - gcc_jit_param *param[] = + gcc_jit_param *params[] = { gcc_jit_context_new_param (comp.ctxt, NULL, comp.ptrdiff_type, @@ -3698,19 +3696,34 @@ declare_function (Lisp_Object func) NULL, comp.lisp_obj_ptr_type, "args") }; - gcc_func = + res = gcc_jit_context_new_function (comp.ctxt, NULL, GCC_JIT_FUNCTION_EXPORTED, comp.lisp_obj_type, - c_name, 2, param, 0); + c_name, ARRAYELTS (params), params, 0); } + SAFE_FREE (); + return res; +} + +/* Declare a function being compiled and add it to comp.exported_funcs_h. */ +static void +declare_function (Lisp_Object func) +{ + gcc_jit_function *gcc_func = + !NILP (CALL1I (comp-func-l-p, func)) + ? declare_lex_function (func) + : gcc_jit_context_new_function (comp.ctxt, + NULL, + GCC_JIT_FUNCTION_EXPORTED, + comp.lisp_obj_type, + SSDATA (CALL1I (comp-func-c-name, func)), + 0, NULL, 0); Fputhash (CALL1I (comp-func-c-name, func), make_mint_ptr (gcc_func), comp.exported_funcs_h); - - SAFE_FREE (); } static void @@ -4685,12 +4698,20 @@ make_subr (Lisp_Object symbol_name, Lisp_Object minarg, Lisp_Object maxarg, void *func = dynlib_sym (handle, SSDATA (c_name)); eassert (func); - union Aligned_Lisp_Subr *x = (union Aligned_Lisp_Subr *) allocate_pseudovector ( VECSIZE (union Aligned_Lisp_Subr), 0, VECSIZE (union Aligned_Lisp_Subr), PVEC_SUBR); + if (CONSP (minarg)) + { + /* Dynamic code. */ + x->s.lambda_list[0] = maxarg; + maxarg = XCDR (minarg); + minarg = XCAR (minarg); + } + else + x->s.lambda_list[0] = Qnil; x->s.function.a0 = func; x->s.min_args = XFIXNUM (minarg); x->s.max_args = FIXNUMP (maxarg) ? XFIXNUM (maxarg) : MANY; diff --git a/src/eval.c b/src/eval.c index 9e86a18590..f2a85691b4 100644 --- a/src/eval.c +++ b/src/eval.c @@ -2275,7 +2275,7 @@ eval_sub (Lisp_Object form) else if (!NILP (fun) && (fun = XSYMBOL (fun)->u.s.function, SYMBOLP (fun))) fun = indirect_function (fun); - if (SUBRP (fun)) + if (SUBRP (fun) && !SUBR_NATIVE_COMPILED_DYNP (fun)) { Lisp_Object args_left = original_args; ptrdiff_t numargs = list_length (args_left); @@ -2378,7 +2378,9 @@ eval_sub (Lisp_Object form) } } } - else if (COMPILEDP (fun) || MODULE_FUNCTIONP (fun)) + else if (COMPILEDP (fun) + || SUBR_NATIVE_COMPILED_DYNP (fun) + || MODULE_FUNCTIONP (fun)) return apply_lambda (fun, original_args, count); else { @@ -2854,9 +2856,11 @@ usage: (funcall FUNCTION &rest ARGUMENTS) */) && (fun = XSYMBOL (fun)->u.s.function, SYMBOLP (fun))) fun = indirect_function (fun); - if (SUBRP (fun)) + if (SUBRP (fun) && !SUBR_NATIVE_COMPILED_DYNP (fun)) val = funcall_subr (XSUBR (fun), numargs, args + 1); - else if (COMPILEDP (fun) || MODULE_FUNCTIONP (fun)) + else if (COMPILEDP (fun) + || SUBR_NATIVE_COMPILED_DYNP (fun) + || MODULE_FUNCTIONP (fun)) val = funcall_lambda (fun, numargs, args + 1); else { @@ -3066,6 +3070,11 @@ funcall_lambda (Lisp_Object fun, ptrdiff_t nargs, else if (MODULE_FUNCTIONP (fun)) return funcall_module (fun, nargs, arg_vector); #endif + else if (SUBR_NATIVE_COMPILED_DYNP (fun)) + { + syms_left = XSUBR (fun)->lambda_list[0]; + lexenv = Qnil; + } else emacs_abort (); @@ -3126,6 +3135,13 @@ funcall_lambda (Lisp_Object fun, ptrdiff_t nargs, if (CONSP (fun)) val = Fprogn (XCDR (XCDR (fun))); + else if (SUBR_NATIVE_COMPILEDP (fun)) + { + eassert (SUBR_NATIVE_COMPILED_DYNP (fun)); + /* No need to use funcall_subr as we have zero arguments by + construction. */ + val = XSUBR (fun)->function.a0 (); + } else val = fetch_and_exec_byte_code (fun, Qnil, 0, NULL); diff --git a/src/lisp.h b/src/lisp.h index bef2e8079e..70ef7db8ee 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -2096,6 +2096,7 @@ struct Lisp_Subr EMACS_INT doc; Lisp_Object native_comp_u[NATIVE_COMP_FLAG]; char *native_c_name[NATIVE_COMP_FLAG]; + Lisp_Object lambda_list[NATIVE_COMP_FLAG]; } GCALIGNED_STRUCT; union Aligned_Lisp_Subr { @@ -4759,6 +4760,12 @@ SUBR_NATIVE_COMPILEDP (Lisp_Object a) return SUBRP (a) && !NILP (XSUBR (a)->native_comp_u[0]); } +INLINE bool +SUBR_NATIVE_COMPILED_DYNP (Lisp_Object a) +{ + return SUBR_NATIVE_COMPILEDP (a) && !NILP (XSUBR (a)->lambda_list[0]); +} + INLINE struct Lisp_Native_Comp_Unit * allocate_native_comp_unit (void) { @@ -4772,6 +4779,12 @@ SUBR_NATIVE_COMPILEDP (Lisp_Object a) return false; } +INLINE bool +SUBR_NATIVE_COMPILED_DYNP (Lisp_Object a) +{ + return false; +} + #endif /* Defined in lastfile.c. */ diff --git a/src/pdumper.c b/src/pdumper.c index e6c877cbbe..2bda3a85cd 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -2937,7 +2937,7 @@ dump_bool_vector (struct dump_context *ctx, const struct Lisp_Vector *v) static dump_off dump_subr (struct dump_context *ctx, const struct Lisp_Subr *subr) { -#if CHECK_STRUCTS && !defined (HASH_Lisp_Subr_92BED44D81) +#if CHECK_STRUCTS && !defined (HASH_Lisp_Subr_35CE99B716) # error "Lisp_Subr changed. See CHECK_STRUCTS comment in config.h." #endif struct Lisp_Subr out; @@ -2968,8 +2968,9 @@ dump_subr (struct dump_context *ctx, const struct Lisp_Subr *subr) dump_field_lv (ctx, &out, subr, &subr->native_comp_u[0], WEIGHT_NORMAL); if (!NILP (subr->native_comp_u[0])) dump_field_fixup_later (ctx, &out, subr, &subr->native_c_name[0]); - } + dump_field_lv (ctx, &out, subr, &subr->lambda_list[0], WEIGHT_NORMAL); + } dump_off subr_off = dump_object_finish (ctx, &out, sizeof (out)); if (NATIVE_COMP_FLAG && ctx->flags.dump_object_contents commit 5a55a845a7c426e82e8a6a6d02bc4a39992871e3 Author: Andrea Corallo Date: Sat Jun 13 11:12:15 2020 +0200 * Implement 'maybe_gc_or_quit' to allow correct GC in compiled Lisp. Implement the backend side of 'maybe_gc_or_quit' so that every time a call to it is emitted we render it accordingly. This allow GC to kicks in during long loops in Lisp code. * src/comp.c (comp_t): Add 'maybe_gc_or_quit' field. (helper_link_table): Add 'maybe_gc', 'maybe_quit'. (emit_maybe_gc_or_quit): New function. (declare_runtime_imported_funcs): Import 'maybe_gc', 'maybe_quit' functions. (define_maybe_gc_or_quit): New function. (Fcomp__init_ctxt): Register emitter. (Fcomp__compile_ctxt_to_file): Call 'define_maybe_gc_or_quit'. (syms_of_comp): Define Qcomp_maybe_gc_or_quit. diff --git a/src/comp.c b/src/comp.c index 18a2a1ff91..24d69b2b1e 100644 --- a/src/comp.c +++ b/src/comp.c @@ -554,6 +554,7 @@ typedef struct { gcc_jit_function *setcdr; gcc_jit_function *check_type; gcc_jit_function *check_impure; + gcc_jit_function *maybe_gc_or_quit; Lisp_Object func_blocks_h; /* blk_name -> gcc_block. */ Lisp_Object exported_funcs_h; /* c-func-name -> gcc_jit_function *. */ Lisp_Object imported_funcs_h; /* subr_name -> gcc_jit_field *reloc_field. */ @@ -610,7 +611,9 @@ void *helper_link_table[] = record_unwind_current_buffer, set_internal, helper_unwind_protect, - specbind }; + specbind, + maybe_gc, + maybe_quit }; static char * ATTRIBUTE_FORMAT_PRINTF (1, 2) @@ -2316,6 +2319,13 @@ emit_integerp (Lisp_Object insn) &res); } +static gcc_jit_rvalue * +emit_maybe_gc_or_quit (Lisp_Object insn) +{ + return gcc_jit_context_new_call (comp.ctxt, NULL, comp.maybe_gc_or_quit, 0, + NULL); +} + /* This is in charge of serializing an object and export a function to retrieve it at load time. */ static void @@ -2575,6 +2585,10 @@ declare_runtime_imported_funcs (void) args[0] = args[1] = comp.lisp_obj_type; ADD_IMPORTED (specbind, comp.void_type, 2, args); + ADD_IMPORTED (maybe_gc, comp.void_type, 0, NULL); + + ADD_IMPORTED (maybe_quit, comp.void_type, 0, NULL); + #undef ADD_IMPORTED return Freverse (field_list); @@ -3512,6 +3526,96 @@ define_CHECK_IMPURE (void) gcc_jit_block_end_with_void_return (err_block, NULL); } +static void +define_maybe_gc_or_quit (void) +{ + + /* + void + maybe_gc_or_quit (void) + { + static unsigned quitcounter; + inc: + quitcounter++; + if (quitcounter >> 14) goto maybe_do_it else goto pass; + maybe_do_it: + quitcounter = 0; + maybe_gc (); + maybe_quit (); + return; + pass: + return; + } + */ + + gcc_jit_block *bb_orig = comp.block; + + gcc_jit_lvalue *quitcounter = + gcc_jit_context_new_global ( + comp.ctxt, + NULL, + GCC_JIT_GLOBAL_INTERNAL, + comp.unsigned_type, + "quitcounter"); + + comp.func = comp.maybe_gc_or_quit = + gcc_jit_context_new_function (comp.ctxt, NULL, + GCC_JIT_FUNCTION_INTERNAL, + comp.void_type, + "maybe_gc_quit", + 0, NULL, 0); + DECL_BLOCK (increment_block, comp.maybe_gc_or_quit); + DECL_BLOCK (maybe_do_it_block, comp.maybe_gc_or_quit); + DECL_BLOCK (pass_block, comp.maybe_gc_or_quit); + + comp.block = increment_block; + + gcc_jit_block_add_assignment ( + comp.block, + NULL, + quitcounter, + emit_binary_op (GCC_JIT_BINARY_OP_PLUS, + comp.unsigned_type, + gcc_jit_lvalue_as_rvalue (quitcounter), + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.unsigned_type, + 1))); + emit_cond_jump ( + emit_binary_op (GCC_JIT_BINARY_OP_RSHIFT, + comp.unsigned_type, + gcc_jit_lvalue_as_rvalue (quitcounter), + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.unsigned_type, + 9)), + /* 9 translates into checking for GC or quit every 512 calls to + 'maybe_gc_quit'. This is the smallest value I could find with + no performance impact running elisp-banechmarks. Byte + intepreter uses 256 (see 'exec_byte_code'). */ + maybe_do_it_block, + pass_block); + + comp.block = maybe_do_it_block; + + gcc_jit_block_add_assignment ( + comp.block, + NULL, + quitcounter, + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.unsigned_type, + 0)); + gcc_jit_block_add_eval (comp.block, NULL, + emit_call (intern_c_string ("maybe_gc"), + comp.void_type, 0, NULL, false)); + gcc_jit_block_add_eval (comp.block, NULL, + emit_call (intern_c_string ("maybe_quit"), + comp.void_type, 0, NULL, false)); + gcc_jit_block_end_with_void_return (comp.block, NULL); + + gcc_jit_block_end_with_void_return (pass_block, NULL); + + comp.block = bb_orig; +} + /* Define a function to convert boolean into t or nil */ static void @@ -3761,6 +3865,7 @@ DEFUN ("comp--init-ctxt", Fcomp__init_ctxt, Scomp__init_ctxt, register_emitter (Qnegate, emit_negate); register_emitter (Qnumberp, emit_numperp); register_emitter (Qintegerp, emit_integerp); + register_emitter (Qcomp_maybe_gc_or_quit, emit_maybe_gc_or_quit); } comp.ctxt = gcc_jit_context_acquire (); @@ -3949,6 +4054,7 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, define_setcar_setcdr (); define_add1_sub1 (); define_negate (); + define_maybe_gc_or_quit (); struct Lisp_Hash_Table *func_h = XHASH_TABLE (CALL1I (comp-ctxt-funcs-h, Vcomp_ctxt)); @@ -4756,6 +4862,7 @@ syms_of_comp (void) DEFSYM (Qnegate, "negate"); DEFSYM (Qnumberp, "numberp"); DEFSYM (Qintegerp, "integerp"); + DEFSYM (Qcomp_maybe_gc_or_quit, "comp-maybe-gc-or-quit"); /* Allocation classes. */ DEFSYM (Qd_default, "d-default"); commit 34ed9d24984360dcc26fc36561f2de6a0917c58e Author: Andrea Corallo Date: Thu Jun 11 22:53:31 2020 +0200 * Introduce latches Define a new kind of basic block 'latch' to close over loops. Its purpose is for now to emit calls to `comp-maybe-gc-or-quit' but in future will be usefull for the loop optimizer to exploit unboxes. * lisp/emacs-lisp/comp.el (comp-block): New base class. (comp-block-lap): New class for LAP derived basic blocks. (comp-latch): New class. (comp-bb-maybe-add, comp-make-curr-block, comp-emit-handler) (comp-emit-switch, comp-emit-switch, comp-limplify-top-level) (comp-addr-to-bb-name, comp-limplify-block) (comp-limplify-function): Update logic for new bb objects arrangment. (comp-latch-make-fill): New function. (comp-emit-uncond-jump, comp-emit-cond-jump): Update to emit latches. (comp-new-block-sym): Add a postfix paramenter. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 2cde99e728..5027d1da08 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -279,16 +279,9 @@ To be used when ncall-conv is nil.")) :documentation "t if rest argument is present.")) (cl-defstruct (comp-block (:copier nil) - (:constructor make--comp-block - (addr sp name))) ; Positional - "A basic block." + (:constructor nil)) + "A base class for basic blocks." (name nil :type symbol) - ;; These two slots are used during limplification. - (sp nil :type number - :documentation "When non nil indicates the sp value while entering -into it.") - (addr nil :type number - :documentation "Start block LAP address.") (insns () :type list :documentation "List of instructions.") (closed nil :type boolean @@ -309,6 +302,22 @@ into it.") :documentation "This is a copy of the frame when leaving the block. Is in use to help the SSA rename pass.")) +(cl-defstruct (comp-block-lap (:copier nil) + (:include comp-block) + (:constructor make--comp-block-lap + (addr sp name))) ; Positional + "A basic block created from lap." + ;; These two slots are used during limplification. + (sp nil :type number + :documentation "When non nil indicates the sp value while entering +into it.") + (addr nil :type number + :documentation "Start block LAP address.")) + +(cl-defstruct (comp-latch (:copier nil) + (:include comp-block)) + "A basic block for a latch loop.") + (cl-defstruct (comp-edge (:copier nil) (:constructor make--comp-edge)) "An edge connecting two basic blocks." (src nil :type comp-block) @@ -751,20 +760,22 @@ Restore the original value afterwards." (defun comp-bb-maybe-add (lap-addr &optional sp) "If necessary create a pending basic block for LAP-ADDR with stack depth SP. The basic block is returned regardless it was already declared or not." - (let ((bb (or (cl-loop ; See if the block was already liplified. + (let ((bb (or (cl-loop ; See if the block was already limplified. for bb being the hash-value in (comp-func-blocks comp-func) - when (equal (comp-block-addr bb) lap-addr) + when (and (comp-block-lap-p bb) + (equal (comp-block-lap-addr bb) lap-addr)) return bb) (cl-find-if (lambda (bb) ; Look within the pendings blocks. - (= (comp-block-addr bb) lap-addr)) + (and (comp-block-lap-p bb) + (= (comp-block-lap-addr bb) lap-addr))) (comp-limplify-pending-blocks comp-pass))))) (if bb (progn - (unless (or (null sp) (= sp (comp-block-sp bb))) + (unless (or (null sp) (= sp (comp-block-lap-sp bb))) (signal 'native-ice (list "incoherent stack pointers" - sp (comp-block-sp bb)))) + sp (comp-block-lap-sp bb)))) bb) - (car (push (make--comp-block lap-addr sp (comp-new-block-sym)) + (car (push (make--comp-block-lap lap-addr sp (comp-new-block-sym)) (comp-limplify-pending-blocks comp-pass)))))) (defsubst comp-call (func &rest args) @@ -832,21 +843,44 @@ If DST-N is specified use it otherwise assume it to be the current slot." ENTRY-SP is the sp value when entering. The block is added to the current function. The block is returned." - (let ((bb (make--comp-block addr entry-sp block-name))) + (let ((bb (make--comp-block-lap addr entry-sp block-name))) (setf (comp-limplify-curr-block comp-pass) bb (comp-limplify-pc comp-pass) addr - (comp-limplify-sp comp-pass) (comp-block-sp bb)) + (comp-limplify-sp comp-pass) (when (comp-block-lap-p bb) + (comp-block-lap-sp bb))) (puthash (comp-block-name bb) bb (comp-func-blocks comp-func)) bb)) +(defun comp-latch-make-fill (target) + "Create a latch pointing to TARGET and fill it. +Return the created latch" + (let ((latch (make-comp-latch :name (comp-new-block-sym "latch"))) + (curr-bb (comp-limplify-curr-block comp-pass))) + ;; See `comp-make-curr-block'. + (setf (comp-limplify-curr-block comp-pass) latch) + (when (< comp-speed 3) + ;; At speed 3 the programmer is responsible to manually + ;; place `comp-maybe-gc-or-quit'. + (comp-emit '(call comp-maybe-gc-or-quit))) + ;; See `comp-emit-uncond-jump'. + (comp-emit `(jump ,(comp-block-name target))) + (comp-mark-curr-bb-closed) + (puthash (comp-block-name latch) latch (comp-func-blocks comp-func)) + (setf (comp-limplify-curr-block comp-pass) curr-bb) + latch)) + (defun comp-emit-uncond-jump (lap-label) "Emit an unconditional branch to LAP-LABEL." (cl-destructuring-bind (label-num . stack-depth) lap-label (when stack-depth (cl-assert (= (1- stack-depth) (comp-sp)))) - (let ((target (comp-bb-maybe-add (comp-label-to-addr label-num) - (comp-sp)))) - (comp-emit `(jump ,(comp-block-name target))) + (let* ((target-addr (comp-label-to-addr label-num)) + (target (comp-bb-maybe-add target-addr + (comp-sp))) + (latch (when (< target-addr (comp-limplify-pc comp-pass)) + (comp-latch-make-fill target))) + (eff-target-name (comp-block-name (or latch target)))) + (comp-emit `(jump ,eff-target-name)) (comp-mark-curr-bb-closed)))) (defun comp-emit-cond-jump (a b target-offset lap-label negated) @@ -859,13 +893,16 @@ Return value is the fall through block name." (let* ((bb (comp-block-name (comp-bb-maybe-add (1+ (comp-limplify-pc comp-pass)) (comp-sp)))) ; Fall through block. (target-sp (+ target-offset (comp-sp))) - (target (comp-block-name (comp-bb-maybe-add (comp-label-to-addr label-num) - target-sp)))) + (target-addr (comp-label-to-addr label-num)) + (target (comp-bb-maybe-add target-addr target-sp)) + (latch (when (< target-addr (comp-limplify-pc comp-pass)) + (comp-latch-make-fill target))) + (eff-target-name (comp-block-name (or latch target)))) (when label-sp (cl-assert (= (1- label-sp) (+ target-offset (comp-sp))))) (comp-emit (if negated - (list 'cond-jump a b target bb) - (list 'cond-jump a b bb target))) + (list 'cond-jump a b eff-target-name bb) + (list 'cond-jump a b bb eff-target-name))) (comp-mark-curr-bb-closed) bb))) @@ -878,7 +915,7 @@ Return value is the fall through block name." (comp-sp))) (handler-bb (comp-bb-maybe-add (comp-label-to-addr label-num) (1+ (comp-sp)))) - (pop-bb (make--comp-block nil (comp-sp) (comp-new-block-sym)))) + (pop-bb (make--comp-block-lap nil (comp-sp) (comp-new-block-sym)))) (comp-emit (list 'push-handler handler-type (comp-slot+1) @@ -904,9 +941,11 @@ Return value is the fall through block name." (comp-slot) (comp-slot+1)))))) -(defun comp-new-block-sym () - "Return a unique symbol naming the next new basic block." - (intern (format "bb_%s" (funcall (comp-func-block-cnt-gen comp-func))))) +(defun comp-new-block-sym (&optional postfix) + "Return a unique symbol postfixing POSTFIX naming the next new basic block." + (intern (format (if postfix "bb_%s_%s" "bb_%s") + (funcall (comp-func-block-cnt-gen comp-func)) + postfix))) (defun comp-fill-label-h () "Fill label-to-addr hash table for the current function." @@ -948,9 +987,9 @@ Return value is the fall through block name." for ff-bb = (if last (comp-bb-maybe-add (1+ (comp-limplify-pc comp-pass)) (comp-sp)) - (make--comp-block nil - (comp-sp) - (comp-new-block-sym))) + (make--comp-block-lap nil + (comp-sp) + (comp-new-block-sym))) for ff-bb-name = (comp-block-name ff-bb) if (eq test-func 'eq) do (comp-emit (list 'cond-jump var m-test ff-bb-name target-name)) @@ -1375,7 +1414,7 @@ into the C code forwarding the compilation unit." :frame-size 1)) (comp-func func) (comp-pass (make-comp-limplify - :curr-block (make--comp-block -1 0 'top-level) + :curr-block (make--comp-block-lap -1 0 'top-level) :frame (comp-new-frame 1)))) (comp-make-curr-block 'entry (comp-sp)) (comp-emit-annotation (if for-late-load @@ -1396,7 +1435,7 @@ into the C code forwarding the compilation unit." "Search for a block starting at ADDR into pending or limplified blocks." ;; FIXME Actually we could have another hash for this. (cl-flet ((pred (bb) - (equal (comp-block-addr bb) addr))) + (equal (comp-block-lap-addr bb) addr))) (if-let ((pending (cl-find-if #'pred (comp-limplify-pending-blocks comp-pass)))) (comp-block-name pending) @@ -1407,8 +1446,8 @@ into the C code forwarding the compilation unit." (defun comp-limplify-block (bb) "Limplify basic-block BB and add it to the current function." (setf (comp-limplify-curr-block comp-pass) bb - (comp-limplify-sp comp-pass) (comp-block-sp bb) - (comp-limplify-pc comp-pass) (comp-block-addr bb)) + (comp-limplify-sp comp-pass) (comp-block-lap-sp bb) + (comp-limplify-pc comp-pass) (comp-block-lap-addr bb)) (puthash (comp-block-name bb) bb (comp-func-blocks comp-func)) (cl-loop for inst-cell on (nthcdr (comp-limplify-pc comp-pass) @@ -1459,7 +1498,8 @@ into the C code forwarding the compilation unit." ;; Sanity check against block duplication. (cl-loop with addr-h = (make-hash-table) for bb being the hash-value in (comp-func-blocks func) - for addr = (comp-block-addr bb) + for addr = (when (comp-block-lap-p bb) + (comp-block-lap-addr bb)) when addr do (cl-assert (null (gethash addr addr-h))) (puthash addr t addr-h)) commit 7f8dbf70a5b0a61345b458537b1a7b4febf468fc Author: Andrea Corallo Date: Sat Jun 13 14:39:49 2020 +0200 Fix const qualifier warnings * src/lisp.h (struct Lisp_Subr): Remove const qualifier from 'native_c_name'. * src/alloc.c (cleanup_vector): Cast to discard const qualifier. diff --git a/src/alloc.c b/src/alloc.c index 514810b83f..42a53276bc 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -3163,7 +3163,9 @@ cleanup_vector (struct Lisp_Vector *vector) PSEUDOVEC_STRUCT (vector, Lisp_Subr); if (!NILP (subr->native_comp_u[0])) { - xfree (subr->symbol_name); + /* FIXME Alternative and non invasive solution to this + cast? */ + xfree ((char *)subr->symbol_name); xfree (subr->native_c_name[0]); } } diff --git a/src/lisp.h b/src/lisp.h index 55055fe284..bef2e8079e 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -2095,7 +2095,7 @@ struct Lisp_Subr }; EMACS_INT doc; Lisp_Object native_comp_u[NATIVE_COMP_FLAG]; - const char *native_c_name[NATIVE_COMP_FLAG]; + char *native_c_name[NATIVE_COMP_FLAG]; } GCALIGNED_STRUCT; union Aligned_Lisp_Subr { commit 88a116d3778982265bdccdd7196a8d76a45736f1 Author: Andrea Corallo Date: Sat Jun 13 08:04:09 2020 +0200 * src/alloc.c (cleanup_vector): Fix --enable-check-lisp-object-type build. diff --git a/src/alloc.c b/src/alloc.c index 750ffbd2dd..514810b83f 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -3161,7 +3161,7 @@ cleanup_vector (struct Lisp_Vector *vector) { struct Lisp_Subr *subr = PSEUDOVEC_STRUCT (vector, Lisp_Subr); - if (subr->native_comp_u[0]) + if (!NILP (subr->native_comp_u[0])) { xfree (subr->symbol_name); xfree (subr->native_c_name[0]); commit a6cc16d04ca98bcf38c7ebf4d0c5bf68b6b37369 Merge: ab78ed83b9 d8a6d2e481 Author: Andrea Corallo Date: Thu Jun 11 18:37:47 2020 +0200 Merge remote-tracking branch 'savahnna/master' into HEAD commit ab78ed83b977084885265a1842e4e474e0938d9f Author: Andrea Corallo Date: Thu Jun 11 23:24:00 2020 +0200 * Fix memory leak when native compiled function is collected * src/alloc.c (cleanup_vector): Handle native compiled functions. diff --git a/src/alloc.c b/src/alloc.c index 9a9dbb52e7..750ffbd2dd 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -3156,6 +3156,17 @@ cleanup_vector (struct Lisp_Vector *vector) PSEUDOVEC_STRUCT (vector, Lisp_Native_Comp_Unit); dispose_comp_unit (cu, true); } + else if (NATIVE_COMP_FLAG + && PSEUDOVECTOR_TYPEP (&vector->header, PVEC_SUBR)) + { + struct Lisp_Subr *subr = + PSEUDOVEC_STRUCT (vector, Lisp_Subr); + if (subr->native_comp_u[0]) + { + xfree (subr->symbol_name); + xfree (subr->native_c_name[0]); + } + } } /* Reclaim space used by unmarked vectors. */ commit 904550d8c8e1583d0444bcb28b5d1130af6bafc3 Author: Andrea Corallo Date: Thu Jun 11 20:23:00 2020 +0200 Fix recursive load for non cons hashed 'data_ephemeral_vec' content Removing `Vcomp_sym_subr_c_name_h' all c_name functions are GC markable only through 'data_ephemeral_vec'. A recursive load must not overide its content otherwise a previously activated load will have the original content collected before it's used. * src/comp.h (struct Lisp_Native_Comp_Unit): Add 'load_ongoing' field. * src/comp.c (unset_cu_load_ongoing): New function. (load_comp_unit): Update logic to detect and handle recursive loads. diff --git a/src/comp.c b/src/comp.c index 0f7c04129b..18a2a1ff91 100644 --- a/src/comp.c +++ b/src/comp.c @@ -4398,6 +4398,12 @@ check_comp_unit_relocs (struct Lisp_Native_Comp_Unit *comp_u) return true; } +static void +unset_cu_load_ongoing (Lisp_Object comp_u) +{ + XNATIVE_COMP_UNIT (comp_u)->load_ongoing = false; +} + void load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u, bool loading_dump, bool late_load) @@ -4433,6 +4439,14 @@ load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u, bool loading_dump, else *saved_cu = comp_u_lisp_obj; + /* Once we are sure to have the right compilation unit we want to + identify is we have at least another load active on it. */ + bool recursive_load = comp_u->load_ongoing; + comp_u->load_ongoing = true; + ptrdiff_t count = SPECPDL_INDEX (); + if (!recursive_load) + record_unwind_protect (unset_cu_load_ongoing, comp_u_lisp_obj); + freloc_check_fill (); Lisp_Object (*top_level_run)(Lisp_Object) @@ -4508,14 +4522,21 @@ load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u, bool loading_dump, are necessary exclusively during the first load. Once these are collected we don't have to maintain them in the heap forever. */ + Lisp_Object volatile data_ephemeral_vec; + /* In case another load of the same CU is active on the stack + all ephemeral data is hold by that frame. Re-writing + 'data_ephemeral_vec' would be not only a waste of cycles but + more importanly would lead to crashed if the contained data + is not cons hashed. */ + if (!recursive_load) + { + Lisp_Object volatile data_ephemeral_vec = + load_static_obj (comp_u, TEXT_DATA_RELOC_EPHEMERAL_SYM); - Lisp_Object volatile data_ephemeral_vec = - load_static_obj (comp_u, TEXT_DATA_RELOC_EPHEMERAL_SYM); - - EMACS_INT d_vec_len = XFIXNUM (Flength (data_ephemeral_vec)); - for (EMACS_INT i = 0; i < d_vec_len; i++) - data_eph_relocs[i] = AREF (data_ephemeral_vec, i); - + EMACS_INT d_vec_len = XFIXNUM (Flength (data_ephemeral_vec)); + for (EMACS_INT i = 0; i < d_vec_len; i++) + data_eph_relocs[i] = AREF (data_ephemeral_vec, i); + } /* Executing this will perform all the expected environment modifications. */ top_level_run (comp_u_lisp_obj); @@ -4525,6 +4546,10 @@ load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u, bool loading_dump, eassert (check_comp_unit_relocs (comp_u)); } + if (!recursive_load) + /* Clean-up the load ongoing flag in case. */ + unbind_to (count, Qnil); + return; } diff --git a/src/comp.h b/src/comp.h index 507379bf5e..687e426b1e 100644 --- a/src/comp.h +++ b/src/comp.h @@ -52,7 +52,7 @@ struct Lisp_Native_Comp_Unit /* STUFFS WE DO NOT DUMP!! */ Lisp_Object *data_imp_relocs; bool loaded_once; - + bool load_ongoing; dynlib_handle_ptr handle; #ifdef WINDOWSNT /* We need to store a copy of the original file name in memory that commit 506febd5e72b0cd48acdf8887fb95701004b6e43 Author: Andrea Corallo Date: Thu Jun 11 22:22:00 2020 +0200 Remove `Vcomp_sym_subr_c_name_h' Given there's no more unique relation symbol-name -> c-name remove `Vcomp_sym_subr_c_name_h' and store the c_name directly in struct Lisp_Subr. The old approach would have failed dumping two functions with the same symbol-name. * src/lisp.h (struct Lisp_Subr): Add 'native_c_name' field. * src/pdumper.c (dump_subr): Update hash + dump 'native_c_name'. (dump_cold_native_subr): dump 'native_c_name'. (dump_do_dump_relocation): Update logic for reviving using 'native_c_name'. * src/comp.c (make_subr): Update for 'native_c_name' field. (Fcomp__register_lambda, Fcomp__register_subr): Clean-up code for 'Vcomp_sym_subr_c_name_h' removal. (syms_of_comp): Remove 'Vcomp_sym_subr_c_name_h'. diff --git a/src/comp.c b/src/comp.c index af61d76d46..0f7c04129b 100644 --- a/src/comp.c +++ b/src/comp.c @@ -4567,6 +4567,7 @@ make_subr (Lisp_Object symbol_name, Lisp_Object minarg, Lisp_Object maxarg, x->s.native_intspec = intspec; x->s.doc = XFIXNUM (doc_idx); x->s.native_comp_u[0] = comp_u; + x->s.native_c_name[0] = xstrdup (SSDATA (c_name)); Lisp_Object tem; XSETSUBR (tem, &x->s); @@ -4595,9 +4596,6 @@ DEFUN ("comp--register-lambda", Fcomp__register_lambda, Scomp__register_lambda, from dump. See 'dump_do_dump_relocation'. */ eassert (NILP (Fgethash (c_name, cu->lambda_c_name_idx_h, Qnil))); Fputhash (c_name, reloc_idx, cu->lambda_c_name_idx_h); - /* The key is not really important as long is the same as - symbol_name so use c_name. */ - Fputhash (Fintern (c_name, Qnil), c_name, Vcomp_sym_subr_c_name_h); /* Do the real relocation fixup. */ cu->data_imp_relocs[XFIXNUM (reloc_idx)] = tem; @@ -4618,7 +4616,6 @@ DEFUN ("comp--register-subr", Fcomp__register_subr, Scomp__register_subr, set_symbol_function (name, tem); LOADHIST_ATTACH (Fcons (Qdefun, name)); - Fputhash (name, c_name, Vcomp_sym_subr_c_name_h); return tem; } @@ -4820,10 +4817,6 @@ syms_of_comp (void) to be necessarily exposed to lisp but can easy debug for now. */ DEFVAR_LISP ("comp-subr-list", Vcomp_subr_list, doc: /* List of all defined subrs. */); - DEFVAR_LISP ("comp-sym-subr-c-name-h", Vcomp_sym_subr_c_name_h, - doc: /* Hash table symbol-function -> function-c-name. For - internal use during dump reload */); - Vcomp_sym_subr_c_name_h = CALLN (Fmake_hash_table, QCtest, Qeq); DEFVAR_LISP ("comp-abi-hash", Vcomp_abi_hash, doc: /* String signing the ABI exposed to .eln files. */); Vcomp_abi_hash = Qnil; diff --git a/src/lisp.h b/src/lisp.h index d39300e559..55055fe284 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -2095,6 +2095,7 @@ struct Lisp_Subr }; EMACS_INT doc; Lisp_Object native_comp_u[NATIVE_COMP_FLAG]; + const char *native_c_name[NATIVE_COMP_FLAG]; } GCALIGNED_STRUCT; union Aligned_Lisp_Subr { diff --git a/src/pdumper.c b/src/pdumper.c index 3089adb35d..e6c877cbbe 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -2937,7 +2937,7 @@ dump_bool_vector (struct dump_context *ctx, const struct Lisp_Vector *v) static dump_off dump_subr (struct dump_context *ctx, const struct Lisp_Subr *subr) { -#if CHECK_STRUCTS && !defined (HASH_Lisp_Subr_99B6674034) +#if CHECK_STRUCTS && !defined (HASH_Lisp_Subr_92BED44D81) # error "Lisp_Subr changed. See CHECK_STRUCTS comment in config.h." #endif struct Lisp_Subr out; @@ -2964,7 +2964,11 @@ dump_subr (struct dump_context *ctx, const struct Lisp_Subr *subr) } DUMP_FIELD_COPY (&out, subr, doc); if (NATIVE_COMP_FLAG) - dump_field_lv (ctx, &out, subr, &subr->native_comp_u[0], WEIGHT_NORMAL); + { + dump_field_lv (ctx, &out, subr, &subr->native_comp_u[0], WEIGHT_NORMAL); + if (!NILP (subr->native_comp_u[0])) + dump_field_fixup_later (ctx, &out, subr, &subr->native_c_name[0]); + } dump_off subr_off = dump_object_finish (ctx, &out, sizeof (out)); if (NATIVE_COMP_FLAG @@ -3493,6 +3497,15 @@ dump_cold_native_subr (struct dump_context *ctx, Lisp_Object subr) ALLOW_IMPLICIT_CONVERSION; dump_write (ctx, symbol_name, 1 + strlen (symbol_name)); DISALLOW_IMPLICIT_CONVERSION; + + dump_remember_fixup_ptr_raw + (ctx, + subr_offset + dump_offsetof (struct Lisp_Subr, native_c_name[0]), + ctx->offset); + const char *c_name = XSUBR (subr)->native_c_name[0]; + ALLOW_IMPLICIT_CONVERSION; + dump_write (ctx, c_name, 1 + strlen (c_name)); + DISALLOW_IMPLICIT_CONVERSION; } static void @@ -5342,20 +5355,18 @@ dump_do_dump_relocation (const uintptr_t dump_base, a 'top_level_run' mechanism, we revive them one-by-one here. */ struct Lisp_Subr *subr = dump_ptr (dump_base, reloc_offset); - Lisp_Object name = intern (subr->symbol_name); struct Lisp_Native_Comp_Unit *comp_u = XNATIVE_COMP_UNIT (subr->native_comp_u[0]); if (!comp_u->handle) error ("can't relocate native subr with not loaded compilation unit"); - Lisp_Object c_name = Fgethash (name, Vcomp_sym_subr_c_name_h, Qnil); - if (NILP (c_name)) - error ("missing label name"); - void *func = dynlib_sym (comp_u->handle, SSDATA (c_name)); + const char *c_name = subr->native_c_name[0]; + eassert (c_name); + void *func = dynlib_sym (comp_u->handle, c_name); if (!func) error ("can't find function in compilation unit"); subr->function.a0 = func; Lisp_Object lambda_data_idx = - Fgethash (c_name, comp_u->lambda_c_name_idx_h, Qnil); + Fgethash (build_string (c_name), comp_u->lambda_c_name_idx_h, Qnil); if (!NILP (lambda_data_idx)) { /* This is an anonymous lambda. commit dd939d7484adad7735e66b1759283d00df708e70 Author: Andrea Corallo Date: Tue Jun 9 22:41:19 2020 +0200 * Remove unused 'helper_save_window_excursion' * src/comp.c (helper_unwind_protect): Remove definition and declaration. diff --git a/src/comp.c b/src/comp.c index 521cadcb10..af61d76d46 100644 --- a/src/comp.c +++ b/src/comp.c @@ -591,7 +591,7 @@ typedef struct { /* Helper functions called by the run-time. */ -Lisp_Object helper_save_window_excursion (Lisp_Object v1); + void helper_unwind_protect (Lisp_Object handler); Lisp_Object helper_temp_output_buffer_setup (Lisp_Object x); Lisp_Object helper_unbind_n (Lisp_Object n); @@ -4014,17 +4014,6 @@ DEFUN ("comp-libgccjit-version", Fcomp_libgccjit_version, /* for laziness. Change this if a performance impact is measured. */ /******************************************************************************/ -Lisp_Object -helper_save_window_excursion (Lisp_Object v1) -{ - ptrdiff_t count1 = SPECPDL_INDEX (); - record_unwind_protect (restore_window_configuration, - Fcurrent_window_configuration (Qnil)); - v1 = Fprogn (v1); - unbind_to (count1, v1); - return v1; -} - void helper_unwind_protect (Lisp_Object handler) { commit 10933f235fa2f1d7a3936da173cdd6e807bff57f Author: Nicolás Bértolo Date: Mon Jun 8 22:01:25 2020 -0300 Copy suffixes passed to 'openp' to avoid GC crashes. Fixes bug#41755 In openp_add_middle_dir_to_suffixes we build a heap-based list from the passed suffixes. It is crucial that we don't create a heap-based cons that points to a stack-based list. * src/lread.c (openp_add_middle_dir_to_suffixes): Copy suffixes when building a list of middle-dirs and suffixes. diff --git a/src/lread.c b/src/lread.c index a3e8d07c56..0530848c2b 100644 --- a/src/lread.c +++ b/src/lread.c @@ -1635,21 +1635,27 @@ openp_add_middle_dir_to_suffixes (Lisp_Object suffixes) Lisp_Object extended_suf = Qnil; FOR_EACH_TAIL_SAFE (tail) { -#ifdef HAVE_NATIVE_COMP + /* suffixes may be a stack-based cons pointing to stack-based + strings. We must copy the suffix if we are putting it into + a heap-based cons to avoid a dangling reference. This would + lead to crashes during the GC. */ CHECK_STRING_CAR (tail); char * suf = SSDATA (XCAR (tail)); + Lisp_Object copied_suffix = build_string (suf); +#ifdef HAVE_NATIVE_COMP if (strcmp (NATIVE_ELISP_SUFFIX, suf) == 0) { CHECK_STRING (Vcomp_native_path_postfix); /* Here we add them in the opposite order so that nreverse corrects it. */ - extended_suf = Fcons (Fcons (Qnil, XCAR (tail)), extended_suf); - extended_suf = Fcons (Fcons (Vcomp_native_path_postfix, XCAR (tail)), + extended_suf = Fcons (Fcons (Qnil, copied_suffix), extended_suf); + extended_suf = Fcons (Fcons (Vcomp_native_path_postfix, + copied_suffix), extended_suf); } else #endif - extended_suf = Fcons (Fcons (Qnil, XCAR (tail)), extended_suf); + extended_suf = Fcons (Fcons (Qnil, copied_suffix), extended_suf); } suffixes = Fnreverse (extended_suf); commit 4d1cfd0997c05de4abc5d2f96c17b1c5a02982d6 Author: Nicolás Bértolo Date: Mon Jun 8 20:47:06 2020 -0300 * Fix usage of cl-destructuring-bind in package--delete-directory. * lisp/emacs-lisp/package.el (package--delete-directory): Fix usage of cl-destructuring-bind. diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index 904fc9e109..0171fd56ff 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -2215,7 +2215,7 @@ to `package-user-dir'." (condition-case err (delete-directory dir t) (file-error - (cl-destructuring-bind (reason1 reason2 filename) err + (cl-destructuring-bind (_ reason1 reason2 filename) err (if (and (string= "Removing old name" reason1) (string= "Permission denied" reason2) (string-prefix-p (expand-file-name package-user-dir) commit 5e8cdca71a661a6d95355ac5fdaa1e2fa32ed0df Author: Andrea Corallo Date: Mon Jun 8 22:31:19 2020 +0100 * src/comp.h (struct Lisp_Native_Comp_Unit): Fix missing GCALIGNED_STRUCT. diff --git a/src/comp.h b/src/comp.h index d46cdc735f..507379bf5e 100644 --- a/src/comp.h +++ b/src/comp.h @@ -61,7 +61,7 @@ struct Lisp_Native_Comp_Unit string may have been sweeped. */ char *cfile; #endif -}; +} GCALIGNED_STRUCT; #ifdef HAVE_NATIVE_COMP commit f2864e3354fd60174b1d8df05a301673a81cd3ea Author: Andrea Corallo Date: Mon Jun 8 22:13:29 2020 +0100 Rename lambda_gc_guard -> lambda_gc_guard_h * src/comp.h (struct Lisp_Native_Comp_Unit): Rename lambda_gc_guard -> lambda_gc_guard_h * src/pdumper.c (dump_do_dump_relocation): Likewise. * src/comp.c (check_comp_unit_relocs, Fcomp__register_lambda) (Fnative_elisp_load): Likewise. diff --git a/src/comp.c b/src/comp.c index 960badb646..521cadcb10 100644 --- a/src/comp.c +++ b/src/comp.c @@ -4400,7 +4400,7 @@ check_comp_unit_relocs (struct Lisp_Native_Comp_Unit *comp_u) return false; else if (SUBR_NATIVE_COMPILEDP (x)) { - if (NILP (Fgethash (x, comp_u->lambda_gc_guard, Qnil))) + if (NILP (Fgethash (x, comp_u->lambda_gc_guard_h, Qnil))) return false; } else if (!EQ (data_imp_relocs[i], AREF (comp_u->data_impure_vec, i))) @@ -4601,7 +4601,7 @@ DEFUN ("comp--register-lambda", Fcomp__register_lambda, Scomp__register_lambda, /* We must protect it against GC because the function is not reachable through symbols. */ - Fputhash (tem, Qt, cu->lambda_gc_guard); + Fputhash (tem, Qt, cu->lambda_gc_guard_h); /* This is for fixing up the value in d_reloc while resurrecting from dump. See 'dump_do_dump_relocation'. */ eassert (NILP (Fgethash (c_name, cu->lambda_c_name_idx_h, Qnil))); @@ -4669,7 +4669,7 @@ DEFUN ("native-elisp-load", Fnative_elisp_load, Snative_elisp_load, 1, 2, 0, comp_u->cfile = xlispstrdup (file); #endif comp_u->data_vec = Qnil; - comp_u->lambda_gc_guard = CALLN (Fmake_hash_table, QCtest, Qeq); + comp_u->lambda_gc_guard_h = CALLN (Fmake_hash_table, QCtest, Qeq); comp_u->lambda_c_name_idx_h = CALLN (Fmake_hash_table, QCtest, Qequal); load_comp_unit (comp_u, false, !NILP (late_load)); diff --git a/src/comp.h b/src/comp.h index 1f64a6df55..d46cdc735f 100644 --- a/src/comp.h +++ b/src/comp.h @@ -37,9 +37,9 @@ struct Lisp_Native_Comp_Unit /* Original eln file loaded. */ Lisp_Object file; Lisp_Object optimize_qualities; - /* Guard anonymous lambdas against Garbage Collection and make them - dumpable. */ - Lisp_Object lambda_gc_guard; + /* Guard anonymous lambdas against Garbage Collection and serve + sanity checks. */ + Lisp_Object lambda_gc_guard_h; /* Hash c_name -> d_reloc_imp index. */ Lisp_Object lambda_c_name_idx_h; /* Hash doc-idx -> function documentaiton. */ diff --git a/src/pdumper.c b/src/pdumper.c index 8cb9284c01..3089adb35d 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -5299,7 +5299,7 @@ dump_do_dump_relocation (const uintptr_t dump_base, static enum { UNKNOWN, LOCAL_BUILD, INSTALLED } installation_state; struct Lisp_Native_Comp_Unit *comp_u = dump_ptr (dump_base, reloc_offset); - comp_u->lambda_gc_guard = CALLN (Fmake_hash_table, QCtest, Qeq); + comp_u->lambda_gc_guard_h = CALLN (Fmake_hash_table, QCtest, Qeq); if (!CONSP (comp_u->file)) error ("Trying to load incoherent dumped .eln"); @@ -5367,7 +5367,7 @@ dump_do_dump_relocation (const uintptr_t dump_base, &(comp_u->data_imp_relocs[XFIXNUM (lambda_data_idx)]); eassert (EQ (*fixup, Qlambda_fixup)); *fixup = tem; - Fputhash (tem, Qt, comp_u->lambda_gc_guard); + Fputhash (tem, Qt, comp_u->lambda_gc_guard_h); } break; } commit 4784bcc96b32f2fc796c7067d2a6c8ddf00f4242 Author: Andrea Corallo Date: Mon Jun 8 17:21:03 2020 +0200 * Fix load logic for the reloading CU case (bug#41754) * src/comp.c (load_comp_unit): When swapping the compilation unit abandoning the new one for the original do not forget to set its loaded_once field to true because is in use by `comp--register-lambda'. (Fcomp__register_lambda): Add sanity a check to spot early if we are trying to load the same lambda twice. diff --git a/src/comp.c b/src/comp.c index b2dbfe88b3..960badb646 100644 --- a/src/comp.c +++ b/src/comp.c @@ -4439,6 +4439,7 @@ load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u, bool loading_dump, { comp_u_lisp_obj = *saved_cu; comp_u = XNATIVE_COMP_UNIT (comp_u_lisp_obj); + comp_u->loaded_once = true; } else *saved_cu = comp_u_lisp_obj; @@ -4603,6 +4604,7 @@ DEFUN ("comp--register-lambda", Fcomp__register_lambda, Scomp__register_lambda, Fputhash (tem, Qt, cu->lambda_gc_guard); /* This is for fixing up the value in d_reloc while resurrecting from dump. See 'dump_do_dump_relocation'. */ + eassert (NILP (Fgethash (c_name, cu->lambda_c_name_idx_h, Qnil))); Fputhash (c_name, reloc_idx, cu->lambda_c_name_idx_h); /* The key is not really important as long is the same as symbol_name so use c_name. */ commit 3d3737b90ab4dcded11ec716f92b9fa8a5c3fbeb Author: Andrea Corallo Date: Mon Jun 8 18:34:46 2020 +0200 * Move final log after containers has been finalized * lisp/emacs-lisp/comp.el (comp-final): Remove function log. (comp-compile-ctxt-to-file): Add function log. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index a6bf723f54..2cde99e728 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2305,6 +2305,9 @@ Update all insn accordingly." Prepare every function for final compilation and drive the C back-end." (let ((dir (file-name-directory name))) (comp-finalize-relocs) + (maphash (lambda (_ f) + (comp-log-func f 1)) + (comp-ctxt-funcs-h comp-ctxt)) (unless (file-exists-p dir) ;; In case it's created in the meanwhile. (ignore-error 'file-already-exists @@ -2315,9 +2318,6 @@ Prepare every function for final compilation and drive the C back-end." (defun comp-final (_) "Final pass driving the C back-end for code emission." (let (compile-result) - (maphash (lambda (_ f) - (comp-log-func f 1)) - (comp-ctxt-funcs-h comp-ctxt)) (comp--init-ctxt) (unwind-protect (setf compile-result commit dfa52572bdc1024342fa1a227ff627386e097a12 Author: Andrea Corallo Date: Tue Jun 9 00:06:33 2020 +0200 * src/pdumper.c (dump_do_dump_relocation): Fix 'lambda_gc_guard' fill value. Given 'lambda_gc_guard' is in use for sanity checking fill it with t as value. diff --git a/src/pdumper.c b/src/pdumper.c index 92ac96a8fa..8cb9284c01 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -5367,7 +5367,7 @@ dump_do_dump_relocation (const uintptr_t dump_base, &(comp_u->data_imp_relocs[XFIXNUM (lambda_data_idx)]); eassert (EQ (*fixup, Qlambda_fixup)); *fixup = tem; - Fputhash (tem, Qnil, comp_u->lambda_gc_guard); + Fputhash (tem, Qt, comp_u->lambda_gc_guard); } break; } commit 3d576c784b3fa01b4d6b33a4172351b7c3a61660 Merge: fbf4882a8b 53fba73ff2 Author: Andrea Corallo Date: Sun Jun 7 20:08:54 2020 +0200 Merge remote-tracking branch 'savannah/master' into dev commit fbf4882a8babd6cab83e78048d5173fef6501393 Author: Andrea Corallo Date: Sun Jun 7 14:42:12 2020 +0200 * Rename comp-function-optimizable -> comp-function-optimizable-p * lisp/emacs-lisp/comp.el (comp-function-optimizable): Rename into 'comp-function-optimizable-p'. (comp-function-call-maybe-remove): Use the new name. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 520ec8cd44..a6bf723f54 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1870,7 +1870,7 @@ Here goes everything that can be done not iteratively (read once). (comp-mvar-type lval) (comp-mvar-type rval))) ;; Here should fall most of (defun byte-optimize-* equivalents. -(defsubst comp-function-optimizable (f args) +(defsubst comp-function-optimizable-p (f args) "Given function F called with ARGS return non nil when optimizable." (when (cl-every #'comp-mvar-const-vld args) (or (get f 'pure) @@ -1900,7 +1900,7 @@ Here goes everything that can be done not iteratively (read once). comp-symbol-values-optimizable))) (rewrite-insn-as-setimm insn (symbol-value (comp-mvar-constant (car args)))))) - ((comp-function-optimizable f args) + ((comp-function-optimizable-p f args) (ignore-errors ;; No point to complain here because we should do basic block ;; pruning in order to be sure that this is not dead-code. This commit 88ccee4083f9059603c8bf9b989848c41902d8b0 Author: Andrea Corallo Date: Sun Jun 7 13:58:27 2020 +0200 * Fix comp-call-optim-form-call for null `callee' * lisp/emacs-lisp/comp.el (comp-call-optim-form-call): Guard agains null `calle'. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index ecd411591a..520ec8cd44 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2023,7 +2023,8 @@ FUNCTION can be a function-name or byte compiled function." ;; Fill missing args to reach TOTAL (append args (cl-loop repeat (- total (length args)) collect (make-comp-mvar :constant nil))))) - (when (and (or (symbolp callee) + (when (and callee + (or (symbolp callee) (gethash callee (comp-ctxt-byte-func-to-func-h comp-ctxt))) (not (memq callee comp-never-optimize-functions))) (let* ((f (if (symbolp callee) commit 47a6fbd38278b40737d498a41a35259458633136 Author: Andrea Corallo Date: Sun Jun 7 11:46:08 2020 +0200 * Improve propagate pass As function folding can generate 'setimm' insns handle them in the `comp-propagate-insn'. * lisp/emacs-lisp/comp.el (comp-propagate-insn): Handle 'setimm' insn. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 4926c5d683..ecd411591a 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1926,6 +1926,10 @@ Here goes everything that can be done not iteratively (read once). (comp-function-call-maybe-remove insn f args))) (_ (comp-mvar-propagate lval rval)))) + (`(setimm ,lval ,v) + (setf (comp-mvar-const-vld lval) t + (comp-mvar-constant lval) v + (comp-mvar-type lval) (comp-strict-type-of v))) (`(phi ,lval . ,rest) ;; Forward const prop here. (when-let* ((vld (cl-every #'comp-mvar-const-vld rest)) commit a58fef9f63fd4383c4eae9dfe8ae663b4ed710d1 Author: Andrea Corallo Date: Sun Jun 7 00:34:21 2020 +0200 * Optimize optimizable variables * lisp/emacs-lisp/comp.el (comp-symbol-values-optimizable): New defconst. (comp-function-call-maybe-remove): New logic to to remove unnecessary `symbol-value' calls. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index b8ab48a996..4926c5d683 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -184,6 +184,10 @@ Can be one of: 'd-default', 'd-impure' or 'd-ephemeral'. See `comp-ctxt'.") (comp-hint-cons . cons)) "Alist used for type propagation.") +(defconst comp-symbol-values-optimizable '(most-positive-fixnum + most-negative-fixnum) + "Symbol values we can resolve in the compile-time.") + (defconst comp-type-hints '(comp-hint-fixnum comp-hint-cons) "List of fake functions used to give compiler hints.") @@ -1883,17 +1887,28 @@ Here goes everything that can be done not iteratively (read once). (defsubst comp-function-call-maybe-remove (insn f args) "Given INSN when F is pure if all ARGS are known remove the function call." - (when (comp-function-optimizable f args) - (ignore-errors - ;; No point to complain here because we should do basic block - ;; pruning in order to be sure that this is not dead-code. This - ;; is now left to gcc, to be implemented only if we want a - ;; reliable diagnostic here. - (let ((value (apply f (mapcar #'comp-mvar-constant args)))) - ;; See `comp-emit-setimm'. - (comp-add-const-to-relocs value) - (setf (car insn) 'setimm - (cddr insn) `(,value)))))) + (cl-flet ((rewrite-insn-as-setimm (insn value) + ;; See `comp-emit-setimm'. + (comp-add-const-to-relocs value) + (setf (car insn) 'setimm + (cddr insn) `(,value)))) + (cond + ((eq f 'symbol-value) + (when-let* ((arg0 (car args)) + (const (comp-mvar-const-vld arg0)) + (ok-to-optim (member (comp-mvar-constant arg0) + comp-symbol-values-optimizable))) + (rewrite-insn-as-setimm insn (symbol-value (comp-mvar-constant + (car args)))))) + ((comp-function-optimizable f args) + (ignore-errors + ;; No point to complain here because we should do basic block + ;; pruning in order to be sure that this is not dead-code. This + ;; is now left to gcc, to be implemented only if we want a + ;; reliable diagnostic here. + (rewrite-insn-as-setimm insn + (apply f + (mapcar #'comp-mvar-constant args)))))))) (defun comp-propagate-insn (insn) "Propagate within INSN." commit 489a79de96c7f90271e57b86b8162ef7ba500fed Author: Andrea Corallo Date: Sat Jun 6 16:53:34 2020 +0200 * Mitigate possible speed 3 miss-optimization Do not perform trampoline optimization at speed 3 on function if their name is not unique inside the compilation unit. Note that the function can still be redefined in any other way therefore this is a mitigation. * lisp/emacs-lisp/comp.el (comp-func-unique-in-cu-p): New predicate. (comp-call-optim-form-call): Perform trampoline optimization for named functions only if they are unique within the current compilation unit. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index f30409ae5c..b8ab48a996 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -399,6 +399,18 @@ structure.") "Type hint predicate for function name FUNC." (when (memq func comp-type-hints) t)) +(defun comp-func-unique-in-cu-p (func) + "Return t if FUNC is know to be unique in the current compilation unit." + (if (symbolp func) + (cl-loop with h = (make-hash-table :test #'eq) + for f being the hash-value in (comp-ctxt-funcs-h comp-ctxt) + for name = (comp-func-name f) + when (gethash name h) + return nil + do (puthash name t h) + finally return t) + t)) + (defsubst comp-alloc-class-to-container (alloc-class) "Given ALLOC-CLASS return the data container for the current context. Assume allocaiton class 'd-default as default." @@ -2018,7 +2030,8 @@ FUNCTION can be a function-name or byte compiled function." ;; Intra compilation unit procedure call optimization. ;; Attention speed 3 triggers this for non self calls too!! ((and comp-func-callee - (or (>= comp-speed 3) + (or (and (>= comp-speed 3) + (comp-func-unique-in-cu-p callee)) (and (>= comp-speed 2) ;; Anonymous lambdas can't be redefined so are ;; always safe to optimize. commit dcfcbb14f5037d2661280c4bb93e7db618819106 Author: Andrea Corallo Date: Sat Jun 6 14:49:01 2020 +0200 * Allow for optimizing anonymous lambdas in call-optim * lisp/emacs-lisp/comp.el (comp-func-in-unit): New function. (comp-call-optim-form-call): Update logic for optimizing anonymous lambdas. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index e776b66481..f30409ae5c 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1976,19 +1976,31 @@ Backward propagate array placement properties." ;; the full compilation unit. ;; For this reason this is triggered only at comp-speed == 3. +(defun comp-func-in-unit (func) + "Given FUNC return the `comp-fun' definition in the current context. +FUNCTION can be a function-name or byte compiled function." + (if (symbolp func) + (gethash (gethash func + (comp-ctxt-sym-to-c-name-h comp-ctxt)) + (comp-ctxt-funcs-h comp-ctxt)) + (cl-assert (byte-code-function-p func)) + (gethash func (comp-ctxt-byte-func-to-func-h comp-ctxt)))) + (defun comp-call-optim-form-call (callee args) "" (cl-flet ((fill-args (args total) ;; Fill missing args to reach TOTAL (append args (cl-loop repeat (- total (length args)) collect (make-comp-mvar :constant nil))))) - (when (and (symbolp callee) ; Do nothing if callee is a byte compiled func. + (when (and (or (symbolp callee) + (gethash callee (comp-ctxt-byte-func-to-func-h comp-ctxt))) (not (memq callee comp-never-optimize-functions))) - (let* ((f (symbol-function callee)) + (let* ((f (if (symbolp callee) + (symbol-function callee) + (cl-assert (byte-code-function-p callee)) + callee)) (subrp (subrp f)) - (comp-func-callee (gethash (gethash callee - (comp-ctxt-sym-to-c-name-h comp-ctxt)) - (comp-ctxt-funcs-h comp-ctxt)))) + (comp-func-callee (comp-func-in-unit callee))) (cond ((and subrp (not (subr-native-elisp-p f))) ;; Trampoline removal. @@ -2005,8 +2017,12 @@ Backward propagate array placement properties." `(,call-type ,callee ,@args))) ;; Intra compilation unit procedure call optimization. ;; Attention speed 3 triggers this for non self calls too!! - ((and (>= comp-speed 3) - comp-func-callee) + ((and comp-func-callee + (or (>= comp-speed 3) + (and (>= comp-speed 2) + ;; Anonymous lambdas can't be redefined so are + ;; always safe to optimize. + (byte-code-function-p callee)))) (let* ((func-args (comp-func-args comp-func-callee)) (nargs (comp-nargs-p func-args)) (call-type (if nargs 'direct-callref 'direct-call)) commit 6449a058b150edd2a5997d761a284ad6b9b5aa97 Author: Andrea Corallo Date: Sat Jun 6 14:20:47 2020 +0200 * Clean-up unnecessary lisp_X context definition * src/comp.c (Fcomp__init_ctxt, comp_t): Remove lisp_X definition as is used only locally. diff --git a/src/comp.c b/src/comp.c index 9171a6a524..b2dbfe88b3 100644 --- a/src/comp.c +++ b/src/comp.c @@ -489,9 +489,6 @@ typedef struct { gcc_jit_type *ptrdiff_type; gcc_jit_type *uintptr_type; gcc_jit_type *size_t_type; -#if LISP_WORDS_ARE_POINTERS - gcc_jit_type *lisp_X; -#endif gcc_jit_type *lisp_word_type; gcc_jit_type *lisp_word_tag_type; #ifdef LISP_OBJECT_IS_STRUCT @@ -3811,11 +3808,12 @@ DEFUN ("comp--init-ctxt", Fcomp__init_ctxt, Scomp__init_ctxt, sizeof (EMACS_UINT), false); #if LISP_WORDS_ARE_POINTERS - comp.lisp_X = - gcc_jit_struct_as_type (gcc_jit_context_new_opaque_struct (comp.ctxt, - NULL, - "Lisp_X")); - comp.lisp_word_type = gcc_jit_type_get_pointer (comp.lisp_X); + comp.lisp_word_type = + gcc_jit_type_get_pointer ( + gcc_jit_struct_as_type ( + gcc_jit_context_new_opaque_struct (comp.ctxt, + NULL, + "Lisp_X"))); #else comp.lisp_word_type = comp.emacs_int_type; #endif commit e8ab017b6d45aea2514a49f974e649ad1f7297ad Author: Andrea Corallo Date: Sat Jun 6 13:30:59 2020 +0200 Change 'direct-call' 'direct-callref' LIMPLE ops sematinc Is cleaner to have the function c-name as first argument of 'direct-call' 'direct-callref'. This is preparatory to anonymous lambdas optimization. * lisp/emacs-lisp/comp.el (comp-propagate-insn): Use c-name when gathering the comp-func definition for direct calls. (comp-call-optim-form-call): Add put c-name as first argument of direct-call direct-callref when optimizing. * src/comp.c (emit_call): Update logic for having c-name as first arg of direct calls. (emit_call_ref): Rename 'subr_sym' into 'func'. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 5116f88722..e776b66481 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1888,14 +1888,15 @@ Here goes everything that can be done not iteratively (read once). (pcase insn (`(set ,lval ,rval) (pcase rval - (`(,(or 'call 'direct-call) ,f . ,args) - (setf (comp-mvar-type lval) - (alist-get f comp-known-ret-types)) - (comp-function-call-maybe-remove insn f args)) - (`(,(or 'callref 'direct-callref) ,f . ,args) + (`(,(or 'call 'callref) ,f . ,args) (setf (comp-mvar-type lval) (alist-get f comp-known-ret-types)) (comp-function-call-maybe-remove insn f args)) + (`(,(or 'direct-call 'direct-callref) ,f . ,args) + (let ((f (comp-func-name (gethash f (comp-ctxt-funcs-h comp-ctxt))))) + (setf (comp-mvar-type lval) + (alist-get f comp-known-ret-types)) + (comp-function-call-maybe-remove insn f args))) (_ (comp-mvar-propagate lval rval)))) (`(phi ,lval . ,rest) @@ -1985,9 +1986,9 @@ Backward propagate array placement properties." (not (memq callee comp-never-optimize-functions))) (let* ((f (symbol-function callee)) (subrp (subrp f)) - (callee-in-unit (gethash (gethash callee - (comp-ctxt-sym-to-c-name-h comp-ctxt)) - (comp-ctxt-funcs-h comp-ctxt)))) + (comp-func-callee (gethash (gethash callee + (comp-ctxt-sym-to-c-name-h comp-ctxt)) + (comp-ctxt-funcs-h comp-ctxt)))) (cond ((and subrp (not (subr-native-elisp-p f))) ;; Trampoline removal. @@ -1995,7 +1996,7 @@ Backward propagate array placement properties." (maxarg (cdr (subr-arity f))) (call-type (if (if subrp (not (numberp maxarg)) - (comp-nargs-p callee-in-unit)) + (comp-nargs-p comp-func-callee)) 'callref 'call)) (args (if (eq call-type 'callref) @@ -2005,14 +2006,14 @@ Backward propagate array placement properties." ;; Intra compilation unit procedure call optimization. ;; Attention speed 3 triggers this for non self calls too!! ((and (>= comp-speed 3) - callee-in-unit) - (let* ((func-args (comp-func-args callee-in-unit)) + comp-func-callee) + (let* ((func-args (comp-func-args comp-func-callee)) (nargs (comp-nargs-p func-args)) (call-type (if nargs 'direct-callref 'direct-call)) (args (if (eq call-type 'direct-callref) args (fill-args args (comp-args-max func-args))))) - `(,call-type ,callee ,@args))) + `(,call-type ,(comp-func-c-name comp-func-callee) ,@args))) ((comp-type-hint-p callee) `(call ,callee ,@args))))))) diff --git a/src/comp.c b/src/comp.c index 45904a3bb1..9171a6a524 100644 --- a/src/comp.c +++ b/src/comp.c @@ -860,34 +860,28 @@ declare_imported_func (Lisp_Object subr_sym, gcc_jit_type *ret_type, } /* Emit calls fetching from existing declarations. */ + static gcc_jit_rvalue * -emit_call (Lisp_Object subr_sym, gcc_jit_type *ret_type, ptrdiff_t nargs, +emit_call (Lisp_Object func, gcc_jit_type *ret_type, ptrdiff_t nargs, gcc_jit_rvalue **args, bool direct) { - Lisp_Object func; - if (direct) - { - Lisp_Object c_name = - Fgethash (subr_sym, - CALL1I (comp-ctxt-sym-to-c-name-h, Vcomp_ctxt), - Qnil); - func = Fgethash (c_name, comp.exported_funcs_h, Qnil); - } - else - func = Fgethash (subr_sym, comp.imported_funcs_h, Qnil); + Lisp_Object gcc_func = + Fgethash (func, + direct ? comp.exported_funcs_h : comp.imported_funcs_h, + Qnil); - if (NILP (func)) + if (NILP (gcc_func)) xsignal2 (Qnative_ice, build_string ("missing function declaration"), - subr_sym); + func); if (direct) { - emit_comment (format_string ("direct call to subr: %s", - SSDATA (SYMBOL_NAME (subr_sym)))); + emit_comment (format_string ("direct call to: %s", + SSDATA (func))); return gcc_jit_context_new_call (comp.ctxt, NULL, - xmint_pointer (func), + xmint_pointer (gcc_func), nargs, args); } @@ -897,14 +891,14 @@ emit_call (Lisp_Object subr_sym, gcc_jit_type *ret_type, ptrdiff_t nargs, gcc_jit_rvalue_dereference_field ( gcc_jit_lvalue_as_rvalue (comp.func_relocs), NULL, - (gcc_jit_field *) xmint_pointer (func)); + (gcc_jit_field *) xmint_pointer (gcc_func)); if (!f_ptr) xsignal2 (Qnative_ice, build_string ("missing function relocation"), - subr_sym); + func); emit_comment (format_string ("calling subr: %s", - SSDATA (SYMBOL_NAME (subr_sym)))); + SSDATA (SYMBOL_NAME (func)))); return gcc_jit_context_new_call_through_ptr (comp.ctxt, NULL, gcc_jit_lvalue_as_rvalue (f_ptr), @@ -914,7 +908,7 @@ emit_call (Lisp_Object subr_sym, gcc_jit_type *ret_type, ptrdiff_t nargs, } static gcc_jit_rvalue * -emit_call_ref (Lisp_Object subr_sym, ptrdiff_t nargs, +emit_call_ref (Lisp_Object func, ptrdiff_t nargs, gcc_jit_lvalue *base_arg, bool direct) { gcc_jit_rvalue *args[] = @@ -922,7 +916,7 @@ emit_call_ref (Lisp_Object subr_sym, ptrdiff_t nargs, comp.ptrdiff_type, nargs), gcc_jit_lvalue_get_address (base_arg, NULL) }; - return emit_call (subr_sym, comp.lisp_obj_type, 2, args, direct); + return emit_call (func, comp.lisp_obj_type, 2, args, direct); } /* Close current basic block emitting a conditional. */ commit e38678b268c2a3f77d1fa32a55706fb9e077405c Author: Nicolás Bértolo Date: Mon May 25 18:05:23 2020 -0300 Reduce the number of files probed when finding a lisp file. * src/lread.c (get-load-suffixes): Do not add any suffix to files that need to be loaded by the dynamic linker. (effective_load_path): Remove function. (load): Don't add any suffix if file ends in a suffix already. (effective_load_path): Remove function. (openp_add_middle_dir_to_suffixes): Add helper function to create pairs of middle directories and suffixes. (openp_max_middledir_and_suffix_len): Add helper function to count the number of bytes needed to store the middle directory and suffix. (openp_fill_filename_buffer): Add helper function to copy middle directory, basename and suffix to the filename buffer. diff --git a/src/lread.c b/src/lread.c index 192c7ba773..a3e8d07c56 100644 --- a/src/lread.c +++ b/src/lread.c @@ -1056,31 +1056,27 @@ This uses the variables `load-suffixes' and `load-file-rep-suffixes'. */) { Lisp_Object exts = Vload_file_rep_suffixes; Lisp_Object suffix = XCAR (suffixes); - FOR_EACH_TAIL (exts) - lst = Fcons (concat2 (suffix, XCAR (exts)), lst); - } - return Fnreverse (lst); -} + bool native_code_suffix = + NATIVE_COMP_FLAG + && strcmp (NATIVE_ELISP_SUFFIX, SSDATA (suffix)) == 0; -static Lisp_Object -effective_load_path (void) -{ -#ifndef HAVE_NATIVE_COMP - return Vload_path; -#else - Lisp_Object lp = Vload_path; - Lisp_Object new_lp = Qnil; - FOR_EACH_TAIL (lp) - { - Lisp_Object el = XCAR (lp); - new_lp = - Fcons (concat2 (Ffile_name_as_directory (el), - Vcomp_native_path_postfix), - new_lp); - new_lp = Fcons (el, new_lp); - } - return Fnreverse (new_lp); +#ifdef HAVE_MODULES + native_code_suffix = + native_code_suffix || strcmp (MODULES_SUFFIX, SSDATA (suffix)) == 0; +#ifdef MODULES_SECONDARY_SUFFIX + native_code_suffix = + native_code_suffix + || strcmp (MODULES_SECONDARY_SUFFIX, SSDATA (suffix)) == 0; #endif +#endif + + if (native_code_suffix) + lst = Fcons (suffix, lst); + else + FOR_EACH_TAIL (exts) + lst = Fcons (concat2 (suffix, XCAR (exts)), lst); + } + return Fnreverse (lst); } /* Return true if STRING ends with SUFFIX. */ @@ -1218,7 +1214,7 @@ Return t if the file exists and loads successfully. */) || suffix_p (file, MODULES_SECONDARY_SUFFIX) #endif #endif - ) + || (NATIVE_COMP_FLAG && suffix_p (file, NATIVE_ELISP_SUFFIX))) must_suffix = Qnil; /* Don't insist on adding a suffix if the argument includes a directory name. */ @@ -1236,8 +1232,7 @@ Return t if the file exists and loads successfully. */) } fd = - openp (effective_load_path (), file, suffixes, &found, Qnil, - load_prefer_newer); + openp (Vload_path, file, suffixes, &found, Qnil, load_prefer_newer); } if (fd == -1) @@ -1612,6 +1607,114 @@ directories, make sure the PREDICATE function returns `dir-ok' for them. */) return file; } +/* This function turns a list of suffixes into a list of middle dirs + and suffixes. If the suffix is not NATIVE_ELISP_SUFFIX then its + suffix is nil and it is added to the list as is. Instead, if it + suffix is NATIVE_ELISP_SUFFIX then two elements are added to the + list. The first one has middledir equal to nil and the second uses + comp-native-path-postfix as middledir. This is because we'd like + to search for dir/foo.eln before dir/middledir/foo.eln. + +For example, it turns this: + +(".eln" ".elc" ".elc.gz" ".el" ".el.gz") + + into this: + +((nil . ".eln") + (comp-native-path-postfix . ".eln") + (nil . ".elc") + (nil . ".elc.gz") + (nil . ".el") + (nil . ".el.gz")) +*/ +static Lisp_Object +openp_add_middle_dir_to_suffixes (Lisp_Object suffixes) +{ + Lisp_Object tail = suffixes; + Lisp_Object extended_suf = Qnil; + FOR_EACH_TAIL_SAFE (tail) + { +#ifdef HAVE_NATIVE_COMP + CHECK_STRING_CAR (tail); + char * suf = SSDATA (XCAR (tail)); + if (strcmp (NATIVE_ELISP_SUFFIX, suf) == 0) + { + CHECK_STRING (Vcomp_native_path_postfix); + /* Here we add them in the opposite order so that nreverse + corrects it. */ + extended_suf = Fcons (Fcons (Qnil, XCAR (tail)), extended_suf); + extended_suf = Fcons (Fcons (Vcomp_native_path_postfix, XCAR (tail)), + extended_suf); + } + else +#endif + extended_suf = Fcons (Fcons (Qnil, XCAR (tail)), extended_suf); + } + + suffixes = Fnreverse (extended_suf); + return suffixes; +} + +/* This function takes a list of middledirs and suffixes and returns + the maximum buffer space that this part of the filename will + need. */ +static ptrdiff_t +openp_max_middledir_and_suffix_len (Lisp_Object middledir_and_suffixes) +{ + ptrdiff_t max_extra_len = 0; + Lisp_Object tail = middledir_and_suffixes; + FOR_EACH_TAIL_SAFE (tail) + { + Lisp_Object middledir_and_suffix = XCAR (tail); + Lisp_Object middledir = XCAR (middledir_and_suffix); + Lisp_Object suffix = XCDR (middledir_and_suffix); + ptrdiff_t len = SBYTES (suffix); + if (!NILP (middledir)) + len += 2 + SBYTES (middledir); /* Add two slashes. */ + max_extra_len = max (max_extra_len, len); + } + return max_extra_len; +} + +/* This function completes the FN buffer with the middledir, + basenameme, and suffix. It takes the directory length in DIRNAME, + but it requires that it has been copied already to the start of + the buffer. + + After this function the FN buffer will be (depending on middledir) + dirname/middledir/basename.suffix + or + dirname/basename.suffix +*/ +static ptrdiff_t +openp_fill_filename_buffer (char *fn, ptrdiff_t dirnamelen, + Lisp_Object basenamewext, + Lisp_Object middledir_and_suffix) +{ + Lisp_Object middledir = XCAR (middledir_and_suffix); + Lisp_Object suffix = XCDR (middledir_and_suffix); + ptrdiff_t basenamewext_len = SBYTES (basenamewext); + ptrdiff_t fnlen, lsuffix = SBYTES (suffix); + ptrdiff_t lmiddledir = 0; + if (!NILP (middledir)) + { + /* Add 1 for the slash. */ + lmiddledir = SBYTES (middledir) + 1; + memcpy (fn + dirnamelen, SDATA (middledir), + lmiddledir - 1); + fn[dirnamelen + (lmiddledir - 1)] = '/'; + } + + memcpy (fn + dirnamelen + lmiddledir, SDATA (basenamewext), + basenamewext_len); + /* Make complete filename by appending SUFFIX. */ + memcpy (fn + dirnamelen + lmiddledir + basenamewext_len, + SDATA (suffix), lsuffix + 1); + fnlen = dirnamelen + lmiddledir + basenamewext_len + lsuffix; + return fnlen; +} + /* Search for a file whose name is STR, looking in directories in the Lisp list PATH, and trying suffixes from SUFFIX. On success, return a file descriptor (or 1 or -2 as described below). @@ -1649,7 +1752,8 @@ openp (Lisp_Object path, Lisp_Object str, Lisp_Object suffixes, ptrdiff_t want_length; Lisp_Object filename; Lisp_Object string, tail, encoded_fn, save_string; - ptrdiff_t max_suffix_len = 0; + Lisp_Object middledir_and_suffixes; + ptrdiff_t max_extra_len = 0; int last_errno = ENOENT; int save_fd = -1; USE_SAFE_ALLOCA; @@ -1660,13 +1764,9 @@ openp (Lisp_Object path, Lisp_Object str, Lisp_Object suffixes, CHECK_STRING (str); - tail = suffixes; - FOR_EACH_TAIL_SAFE (tail) - { - CHECK_STRING_CAR (tail); - max_suffix_len = max (max_suffix_len, - SBYTES (XCAR (tail))); - } + middledir_and_suffixes = openp_add_middle_dir_to_suffixes (suffixes); + + max_extra_len = openp_max_middledir_and_suffix_len (middledir_and_suffixes); string = filename = encoded_fn = save_string = Qnil; @@ -1683,7 +1783,7 @@ openp (Lisp_Object path, Lisp_Object str, Lisp_Object suffixes, executable. */ FOR_EACH_TAIL_SAFE (path) { - ptrdiff_t baselen, prefixlen; + ptrdiff_t dirnamelen, prefixlen; if (EQ (path, just_use_str)) filename = str; @@ -1700,35 +1800,40 @@ openp (Lisp_Object path, Lisp_Object str, Lisp_Object suffixes, continue; } + /* Calculate maximum length of any filename made from this path element/specified file name and any possible suffix. */ - want_length = max_suffix_len + SBYTES (filename); + want_length = max_extra_len + SBYTES (filename); if (fn_size <= want_length) { fn_size = 100 + want_length; fn = SAFE_ALLOCA (fn_size); } + Lisp_Object dirnamewslash = Ffile_name_directory (filename); + Lisp_Object basenamewext = Ffile_name_nondirectory (filename); + /* Copy FILENAME's data to FN but remove starting /: if any. */ - prefixlen = ((SCHARS (filename) > 2 - && SREF (filename, 0) == '/' - && SREF (filename, 1) == ':') + prefixlen = ((SCHARS (dirnamewslash) > 2 + && SREF (dirnamewslash, 0) == '/' + && SREF (dirnamewslash, 1) == ':') ? 2 : 0); - baselen = SBYTES (filename) - prefixlen; - memcpy (fn, SDATA (filename) + prefixlen, baselen); + dirnamelen = SBYTES (dirnamewslash) - prefixlen; + memcpy (fn, SDATA (dirnamewslash) + prefixlen, dirnamelen); - /* Loop over suffixes. */ - AUTO_LIST1 (empty_string_only, empty_unibyte_string); - tail = NILP (suffixes) ? empty_string_only : suffixes; + /* Loop over middledir_and_suffixes. */ + AUTO_LIST1 (empty_string_only, Fcons (Qnil, empty_unibyte_string)); + tail = NILP (middledir_and_suffixes) ? empty_string_only + : middledir_and_suffixes; FOR_EACH_TAIL_SAFE (tail) { - Lisp_Object suffix = XCAR (tail); - ptrdiff_t fnlen, lsuffix = SBYTES (suffix); + Lisp_Object middledir_and_suffix = XCAR (tail); + Lisp_Object suffix = XCDR (middledir_and_suffix); Lisp_Object handler; - /* Make complete filename by appending SUFFIX. */ - memcpy (fn + baselen, SDATA (suffix), lsuffix + 1); - fnlen = baselen + lsuffix; + ptrdiff_t fnlen = openp_fill_filename_buffer (fn, dirnamelen, + basenamewext, + middledir_and_suffix); /* Check that the file exists and is not a directory. */ /* We used to only check for handlers on non-absolute file names: commit ee3df1483a9e733c27629da7bcf515789df52ef8 Merge: 385d9e6974 7ac79872ae Author: Andrea Corallo Date: Sat Jun 6 21:52:00 2020 +0200 Merge remote-tracking branch 'savannah/master' into HEAD commit 385d9e69740e4f6293fe4c7b4206e3a4aca6ca21 Author: Andrea Corallo Date: Sat Jun 6 13:00:45 2020 +0100 Some fixes for --without-nativecomp config * src/pdumper.c (dump_subr): Do not add RELOC_NATIVE_SUBR for VERY_LATE_RELOCS in --without-nativecomp. (dump_do_dump_relocation): Add a sanity check that no RELOC_NATIVE_SUBR exists in --without-nativecomp. * src/lread.c (Fload): As Fnative_elisp_load is not defined in --without-nativecomp so ifdef this block. diff --git a/src/lread.c b/src/lread.c index 026f3b6d98..192c7ba773 100644 --- a/src/lread.c +++ b/src/lread.c @@ -1507,6 +1507,7 @@ Return t if the file exists and loads successfully. */) } else if (is_native_elisp) { +#ifdef HAVE_NATIVE_COMP specbind (Qcurrent_load_list, Qnil); if (!NILP (Vpurify_flag)) { @@ -1517,6 +1518,11 @@ Return t if the file exists and loads successfully. */) LOADHIST_ATTACH (hist_file_name); Fnative_elisp_load (found, Qnil); build_load_history (hist_file_name, true); +#else + /* This cannot happen. */ + emacs_abort (); +#endif + } else { diff --git a/src/pdumper.c b/src/pdumper.c index ffe59fbb30..92ac96a8fa 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -2967,7 +2967,9 @@ dump_subr (struct dump_context *ctx, const struct Lisp_Subr *subr) dump_field_lv (ctx, &out, subr, &subr->native_comp_u[0], WEIGHT_NORMAL); dump_off subr_off = dump_object_finish (ctx, &out, sizeof (out)); - if (ctx->flags.dump_object_contents && !NILP (subr->native_comp_u[0])) + if (NATIVE_COMP_FLAG + && ctx->flags.dump_object_contents + && !NILP (subr->native_comp_u[0])) /* We'll do the final addr relocation during VERY_LATE_RELOCS time after the compilation units has been loaded. */ dump_push (&ctx->dump_relocs[VERY_LATE_RELOCS], @@ -5331,6 +5333,10 @@ dump_do_dump_relocation (const uintptr_t dump_base, } case RELOC_NATIVE_SUBR: { + if (!NATIVE_COMP_FLAG) + /* This cannot happen. */ + emacs_abort (); + /* When resurrecting from a dump given non all the original native compiled subrs may be still around we can't rely on a 'top_level_run' mechanism, we revive them one-by-one commit 5684b3420d73715836c5111ef1f6ec9e4e257e8f Author: Andrea Corallo Date: Thu Jun 4 11:02:51 2020 +0100 * Fix build for --enable-check-lisp-object-type=yes (bug#41703) * src/comp.c (emit_coerce): Add missing declaration. diff --git a/src/comp.c b/src/comp.c index 8e7582b3e6..45904a3bb1 100644 --- a/src/comp.c +++ b/src/comp.c @@ -984,6 +984,7 @@ emit_coerce (gcc_jit_type *new_type, gcc_jit_rvalue *obj) gcc_jit_rvalue *lwordobj = emit_coerce (comp.lisp_word_type, obj); + static ptrdiff_t i; gcc_jit_lvalue *tmp_s = gcc_jit_function_new_local (comp.func, NULL, comp.lisp_obj_type, format_string ("lisp_obj_%td", i++)); commit f5ea65b43678621cb450d7afbcd46032258d4b20 Merge: e4e6bb7fdd 4fff650236 Author: Andrea Corallo Date: Thu Jun 4 10:33:07 2020 +0100 Merge remote-tracking branch 'savannah/master' into HEAD commit e4e6bb7fddaa3a4e82748c106366fe9113dc16d9 Author: Andrea Corallo Date: Wed Jun 3 22:06:26 2020 +0100 * Introduce `comp-loop-insn-in-block' * lisp/emacs-lisp/comp.el (comp-loop-insn-in-block): New macro. (comp-call-optim-func, comp-dead-assignments-func) (comp-remove-type-hints-func): Use `comp-loop-insn-in-block'. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 11539761d1..5116f88722 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -494,6 +494,16 @@ VERBOSITY is a number between 0 and 3." "Output filename for SRC file being native compiled." (concat (comp-output-base-filename src) ".eln")) +(defmacro comp-loop-insn-in-block (basic-block &rest body) + "Loop over all insns in BASIC-BLOCK executning BODY. +Inside BODY `insn' can be used to read or set the current +instruction." + (declare (debug (form body)) + (indent defun)) + (let ((sym-cell (gensym "cell-"))) + `(cl-symbol-macrolet ((insn (car ,sym-cell))) + (cl-loop for ,sym-cell on (comp-block-insns ,basic-block) + do ,@body)))) ;;; spill-lap pass specific code. @@ -2012,18 +2022,16 @@ Backward propagate array placement properties." with self = (comp-func-name comp-func) for b being each hash-value of (comp-func-blocks comp-func) when self ;; FIXME add proper anonymous lambda support. - do (cl-loop - for insn-cell on (comp-block-insns b) - for insn = (car insn-cell) - do (pcase insn - (`(set ,lval (callref funcall ,f . ,rest)) - (when-let ((new-form (comp-call-optim-form-call - (comp-mvar-constant f) rest))) - (setcar insn-cell `(set ,lval ,new-form)))) - (`(callref funcall ,f . ,rest) - (when-let ((new-form (comp-call-optim-form-call - (comp-mvar-constant f) rest))) - (setcar insn-cell new-form))))))) + do (comp-loop-insn-in-block b + (pcase insn + (`(set ,lval (callref funcall ,f . ,rest)) + (when-let ((new-form (comp-call-optim-form-call + (comp-mvar-constant f) rest))) + (setf insn `(set ,lval ,new-form)))) + (`(callref funcall ,f . ,rest) + (when-let ((new-form (comp-call-optim-form-call + (comp-mvar-constant f) rest))) + (setf insn new-form))))))) (defun comp-call-optim (_) "Try to optimize out funcall trampoline usage when possible." @@ -2077,17 +2085,15 @@ Return the list of m-var ids nuked." 3) (cl-loop for b being each hash-value of (comp-func-blocks comp-func) - do (cl-loop - for insn-cell on (comp-block-insns b) - for insn = (car insn-cell) - for (op arg0 rest) = insn - when (and (comp-set-op-p op) - (memq (comp-mvar-id arg0) nuke-list)) - do (setcar insn-cell - (if (comp-limple-insn-call-p rest) - rest - `(comment ,(format "optimized out: %s" - insn)))))) + do (comp-loop-insn-in-block b + (cl-destructuring-bind (op &optional arg0 arg1 &rest rest) insn + (when (and (comp-set-op-p op) + (memq (comp-mvar-id arg0) nuke-list)) + (setf insn + (if (comp-limple-insn-call-p arg1) + arg1 + `(comment ,(format "optimized out: %s" + insn)))))))) nuke-list))) (defun comp-dead-code (_) @@ -2154,12 +2160,10 @@ Return the list of m-var ids nuked." These are substituted with a normal 'set' op." (cl-loop for b being each hash-value of (comp-func-blocks comp-func) - do (cl-loop - for insn-cell on (comp-block-insns b) - for insn = (car insn-cell) - do (pcase insn - (`(set ,l-val (call ,(pred comp-type-hint-p) ,r-val)) - (setcar insn-cell `(set ,l-val ,r-val))))))) + do (comp-loop-insn-in-block b + (pcase insn + (`(set ,l-val (call ,(pred comp-type-hint-p) ,r-val)) + (setf insn `(set ,l-val ,r-val))))))) (defun comp-remove-type-hints (_) "Dead code elimination." commit b619339b7a6c7952508bff72f07fc98c04e85f2c Author: Nicolás Bértolo Date: Mon Jun 1 19:53:00 2020 -0300 Fix DLL imports of gccjit version functions. * src/comp.c (init_gccjit_functions): Use LOAD_DLL_FN_OPT macro to load gcc_jit_version_major, gcc_jit_version_major and gcc_jit_version_patchlevel. * src/w32common.h (LOAD_DLL_FN_OPT): Add macro optionally load a function from a DLL. diff --git a/src/comp.c b/src/comp.c index d0574ac5ef..8e7582b3e6 100644 --- a/src/comp.c +++ b/src/comp.c @@ -98,6 +98,9 @@ along with GNU Emacs. If not, see . */ #undef gcc_jit_struct_as_type #undef gcc_jit_struct_set_fields #undef gcc_jit_type_get_pointer +#undef gcc_jit_version_major +#undef gcc_jit_version_minor +#undef gcc_jit_version_patchlevel /* In alphabetical order */ DEF_DLL_FN (gcc_jit_rvalue *, gcc_jit_context_new_rvalue_from_int, @@ -231,9 +234,9 @@ DEF_DLL_FN (void, gcc_jit_context_set_logfile, DEF_DLL_FN (void, gcc_jit_struct_set_fields, (gcc_jit_struct *struct_type, gcc_jit_location *loc, int num_fields, gcc_jit_field **fields)); -DEF_DLL_FN (int, gcc_jit_version_major); -DEF_DLL_FN (int, gcc_jit_version_minor); -DEF_DLL_FN (int, gcc_jit_version_patchlevel); +DEF_DLL_FN (int, gcc_jit_version_major, (void)); +DEF_DLL_FN (int, gcc_jit_version_minor, (void)); +DEF_DLL_FN (int, gcc_jit_version_patchlevel, (void)); static bool init_gccjit_functions (void) @@ -297,9 +300,9 @@ init_gccjit_functions (void) LOAD_DLL_FN (library, gcc_jit_struct_as_type); LOAD_DLL_FN (library, gcc_jit_struct_set_fields); LOAD_DLL_FN (library, gcc_jit_type_get_pointer); - LOAD_DLL_FN (library, gcc_jit_version_major); - LOAD_DLL_FN (library, gcc_jit_version_minor); - LOAD_DLL_FN (library, gcc_jit_version_patchlevel); + LOAD_DLL_FN_OPT (library, gcc_jit_version_major); + LOAD_DLL_FN_OPT (library, gcc_jit_version_minor); + LOAD_DLL_FN_OPT (library, gcc_jit_version_patchlevel); return true; } @@ -358,6 +361,9 @@ init_gccjit_functions (void) #define gcc_jit_struct_as_type fn_gcc_jit_struct_as_type #define gcc_jit_struct_set_fields fn_gcc_jit_struct_set_fields #define gcc_jit_type_get_pointer fn_gcc_jit_type_get_pointer +#define gcc_jit_version_major fn_gcc_jit_version_major +#define gcc_jit_version_minor fn_gcc_jit_version_minor +#define gcc_jit_version_patchlevel fn_gcc_jit_version_patchlevel #endif diff --git a/src/w32common.h b/src/w32common.h index eb7faa1939..bd01fd4040 100644 --- a/src/w32common.h +++ b/src/w32common.h @@ -81,6 +81,14 @@ get_proc_addr (HINSTANCE handle, LPCSTR fname) } \ while (false) +/* Load a function from the DLL, and don't fail if it does not exist. */ +#define LOAD_DLL_FN_OPT(lib, func) \ + do \ + { \ + fn_##func = (W32_PFN_##func) get_proc_addr (lib, #func); \ + } \ + while (false) + #ifdef HAVE_HARFBUZZ extern bool hbfont_init_w32_funcs (HMODULE); #endif commit 9f6c12be5574060014f91ad6190d79124ea19802 Author: Nicolás Bértolo Date: Sun May 31 18:09:12 2020 -0300 * Throw an ICE when asked to emit a cast with sign extension. * src/comp.c (cast_kind_of_type): Enum that specifies the kind of type in the cast enum (unsigned, signed, pointer). (emit_coerce): Throw an ICE when asked to emit a cast with sign extension. (define_cast_from_to): Return NULL for casts involving sign extension. (define_cast_functions): Specify the kind of each type in the cast union. diff --git a/src/comp.c b/src/comp.c index 8ccae7cf84..d0574ac5ef 100644 --- a/src/comp.c +++ b/src/comp.c @@ -456,6 +456,13 @@ static f_reloc_t freloc; #define NUM_CAST_TYPES 15 +enum cast_kind_of_type + { + kind_unsigned, + kind_signed, + kind_pointer + }; + /* C side of the compiler context. */ typedef struct { @@ -518,10 +525,11 @@ typedef struct { gcc_jit_function *cast_functions_from_to[NUM_CAST_TYPES][NUM_CAST_TYPES]; /* We add one to make space for the last member which is the "biggest_type" member. */ - gcc_jit_type *cast_types[NUM_CAST_TYPES+1]; - size_t cast_type_sizes[NUM_CAST_TYPES+1]; - const char *cast_type_names[NUM_CAST_TYPES+1]; - gcc_jit_field *cast_union_fields[NUM_CAST_TYPES+1]; + gcc_jit_type *cast_types[NUM_CAST_TYPES + 1]; + size_t cast_type_sizes[NUM_CAST_TYPES + 1]; + enum cast_kind_of_type cast_type_kind[NUM_CAST_TYPES + 1]; + const char *cast_type_names[NUM_CAST_TYPES + 1]; + gcc_jit_field *cast_union_fields[NUM_CAST_TYPES + 1]; size_t cast_union_field_biggest_type; gcc_jit_function *func; /* Current function being compiled. */ bool func_has_non_local; /* From comp-func has-non-local slot. */ @@ -986,6 +994,13 @@ emit_coerce (gcc_jit_type *new_type, gcc_jit_rvalue *obj) int old_index = type_to_cast_index (old_type); int new_index = type_to_cast_index (new_type); + if (comp.cast_type_sizes[old_index] < comp.cast_type_sizes[new_index] + && comp.cast_type_kind[new_index] == kind_signed) + xsignal3 (Qnative_ice, + build_string ("FIXME: sign extension not implemented"), + build_string (comp.cast_type_names[old_index]), + build_string (comp.cast_type_names[new_index])); + /* Lookup the appropriate cast function in the cast matrix. */ return gcc_jit_context_new_call (comp.ctxt, NULL, @@ -2919,12 +2934,18 @@ struct cast_type gcc_jit_type *type; const char *name; size_t bytes_size; + enum cast_kind_of_type kind; }; static gcc_jit_function * define_cast_from_to (struct cast_type from, int from_index, struct cast_type to, int to_index) { + /* FIXME: sign extension not implemented. */ + if (comp.cast_type_sizes[from_index] < comp.cast_type_sizes[to_index] + && comp.cast_type_kind[to_index] == kind_signed) + return NULL; + char *name = format_string ("cast_from_%s_to_%s", from.name, to.name); gcc_jit_param *param = gcc_jit_context_new_param (comp.ctxt, NULL, from.type, "arg"); @@ -2973,22 +2994,27 @@ static void define_cast_functions (void) { struct cast_type cast_types[NUM_CAST_TYPES] - = { { comp.bool_type, "bool", sizeof (bool) }, - { comp.char_ptr_type, "char_ptr", sizeof (char *) }, - { comp.int_type, "int", sizeof (int) }, - { comp.lisp_cons_ptr_type, "cons_ptr", sizeof (struct Lisp_Cons *) }, - { comp.lisp_obj_ptr_type, "lisp_obj_ptr", sizeof (Lisp_Object *) }, - { comp.lisp_word_tag_type, "lisp_word_tag", sizeof (Lisp_Word_tag) }, - { comp.lisp_word_type, "lisp_word", sizeof (Lisp_Word) }, - { comp.long_long_type, "long_long", sizeof (long long) }, - { comp.long_type, "long", sizeof (long) }, - { comp.ptrdiff_type, "ptrdiff", sizeof (ptrdiff_t) }, - { comp.uintptr_type, "uintptr", sizeof (uintptr_t) }, + = { { comp.bool_type, "bool", sizeof (bool), kind_unsigned }, + { comp.char_ptr_type, "char_ptr", sizeof (char *), kind_pointer }, + { comp.int_type, "int", sizeof (int), kind_signed }, + { comp.lisp_cons_ptr_type, "cons_ptr", sizeof (struct Lisp_Cons *), + kind_pointer }, + { comp.lisp_obj_ptr_type, "lisp_obj_ptr", sizeof (Lisp_Object *), + kind_pointer }, + { comp.lisp_word_tag_type, "lisp_word_tag", sizeof (Lisp_Word_tag), + kind_unsigned }, + { comp.lisp_word_type, "lisp_word", sizeof (Lisp_Word), + LISP_WORDS_ARE_POINTERS ? kind_pointer : kind_signed }, + { comp.long_long_type, "long_long", sizeof (long long), kind_signed }, + { comp.long_type, "long", sizeof (long), kind_signed }, + { comp.ptrdiff_type, "ptrdiff", sizeof (ptrdiff_t), kind_signed }, + { comp.uintptr_type, "uintptr", sizeof (uintptr_t), kind_unsigned }, { comp.unsigned_long_long_type, "unsigned_long_long", - sizeof (unsigned long long) }, - { comp.unsigned_long_type, "unsigned_long", sizeof (unsigned long) }, - { comp.unsigned_type, "unsigned", sizeof (unsigned) }, - { comp.void_ptr_type, "void_ptr", sizeof (void*) } }; + sizeof (unsigned long long), kind_unsigned }, + { comp.unsigned_long_type, "unsigned_long", sizeof (unsigned long), + kind_unsigned }, + { comp.unsigned_type, "unsigned", sizeof (unsigned), kind_unsigned }, + { comp.void_ptr_type, "void_ptr", sizeof (void*), kind_pointer } }; /* Find the biggest size. It should be unsigned long long, but to be sure we find it programmatically. */ @@ -3006,16 +3032,18 @@ define_cast_functions (void) cast_types[i].name); comp.cast_type_names[i] = cast_types[i].name; comp.cast_type_sizes[i] = cast_types[i].bytes_size; + comp.cast_type_kind[i] = cast_types[i].kind; } gcc_jit_type *biggest_type = gcc_jit_context_get_int_type (comp.ctxt, biggest_size, false); comp.cast_types[NUM_CAST_TYPES] = biggest_type; - comp.cast_union_fields[NUM_CAST_TYPES] - = gcc_jit_context_new_field (comp.ctxt, NULL, biggest_type, "biggest_type"); + comp.cast_union_fields[NUM_CAST_TYPES] = + gcc_jit_context_new_field (comp.ctxt, NULL, biggest_type, "biggest_type"); comp.cast_type_names[NUM_CAST_TYPES] = "biggest_type"; comp.cast_type_sizes[NUM_CAST_TYPES] = biggest_size; + comp.cast_type_kind[NUM_CAST_TYPES] = kind_unsigned; comp.cast_union_type = gcc_jit_context_new_union_type (comp.ctxt, commit 035a91dd963290a40766b430e4e9a108cbbc4eac Author: Nicolás Bértolo Date: Sat May 30 18:33:58 2020 -0300 * Define casts using functions. This is to dump prettier C files. This does not affect compilation times in my tests. * src/comp.c: Define a 15x15 cast matrix. Use it in emit_coerce(). diff --git a/src/comp.c b/src/comp.c index b6726822b7..8ccae7cf84 100644 --- a/src/comp.c +++ b/src/comp.c @@ -454,6 +454,8 @@ sigset_t saved_sigset; static f_reloc_t freloc; +#define NUM_CAST_TYPES 15 + /* C side of the compiler context. */ typedef struct { @@ -513,21 +515,14 @@ typedef struct { /* libgccjit has really limited support for casting therefore this union will be used for the scope. */ gcc_jit_type *cast_union_type; - gcc_jit_field *cast_union_as_ll; - gcc_jit_field *cast_union_as_ull; - gcc_jit_field *cast_union_as_l; - gcc_jit_field *cast_union_as_ul; - gcc_jit_field *cast_union_as_u; - gcc_jit_field *cast_union_as_i; - gcc_jit_field *cast_union_as_b; - gcc_jit_field *cast_union_as_uintptr; - gcc_jit_field *cast_union_as_ptrdiff; - gcc_jit_field *cast_union_as_c_p; - gcc_jit_field *cast_union_as_v_p; - gcc_jit_field *cast_union_as_lisp_cons_ptr; - gcc_jit_field *cast_union_as_lisp_word; - gcc_jit_field *cast_union_as_lisp_word_tag; - gcc_jit_field *cast_union_as_lisp_obj_ptr; + gcc_jit_function *cast_functions_from_to[NUM_CAST_TYPES][NUM_CAST_TYPES]; + /* We add one to make space for the last member which is the "biggest_type" + member. */ + gcc_jit_type *cast_types[NUM_CAST_TYPES+1]; + size_t cast_type_sizes[NUM_CAST_TYPES+1]; + const char *cast_type_names[NUM_CAST_TYPES+1]; + gcc_jit_field *cast_union_fields[NUM_CAST_TYPES+1]; + size_t cast_union_field_biggest_type; gcc_jit_function *func; /* Current function being compiled. */ bool func_has_non_local; /* From comp-func has-non-local slot. */ gcc_jit_lvalue **f_frame; /* "Floating" frame for the current function. */ @@ -684,47 +679,6 @@ bcall0 (Lisp_Object f) Ffuncall (1, &f); } -static gcc_jit_field * -type_to_cast_field (gcc_jit_type *type) -{ - gcc_jit_field *field; - - if (type == comp.long_long_type) - field = comp.cast_union_as_ll; - else if (type == comp.unsigned_long_long_type) - field = comp.cast_union_as_ull; - else if (type == comp.long_type) - field = comp.cast_union_as_l; - else if (type == comp.unsigned_long_type) - field = comp.cast_union_as_ul; - else if (type == comp.unsigned_type) - field = comp.cast_union_as_u; - else if (type == comp.int_type) - field = comp.cast_union_as_i; - else if (type == comp.bool_type) - field = comp.cast_union_as_b; - else if (type == comp.void_ptr_type) - field = comp.cast_union_as_v_p; - else if (type == comp.uintptr_type) - field = comp.cast_union_as_uintptr; - else if (type == comp.ptrdiff_type) - field = comp.cast_union_as_ptrdiff; - else if (type == comp.char_ptr_type) - field = comp.cast_union_as_c_p; - else if (type == comp.lisp_cons_ptr_type) - field = comp.cast_union_as_lisp_cons_ptr; - else if (type == comp.lisp_word_type) - field = comp.cast_union_as_lisp_word; - else if (type == comp.lisp_word_tag_type) - field = comp.cast_union_as_lisp_word_tag; - else if (type == comp.lisp_obj_ptr_type) - field = comp.cast_union_as_lisp_obj_ptr; - else - xsignal1 (Qnative_ice, build_string ("unsupported cast")); - - return field; -} - static gcc_jit_block * retrive_block (Lisp_Object block_name) { @@ -985,11 +939,19 @@ emit_cond_jump (gcc_jit_rvalue *test, } +static int +type_to_cast_index (gcc_jit_type * type) +{ + for (int i = 0; i < NUM_CAST_TYPES; ++i) + if (type == comp.cast_types[i]) + return i; + + xsignal1 (Qnative_ice, build_string ("unsupported cast")); +} + static gcc_jit_rvalue * emit_coerce (gcc_jit_type *new_type, gcc_jit_rvalue *obj) { - static ptrdiff_t i; - gcc_jit_type *old_type = gcc_jit_rvalue_get_type (obj); if (new_type == old_type) @@ -1021,25 +983,14 @@ emit_coerce (gcc_jit_type *new_type, gcc_jit_rvalue *obj) } #endif - gcc_jit_field *orig_field = - type_to_cast_field (old_type); - gcc_jit_field *dest_field = type_to_cast_field (new_type); + int old_index = type_to_cast_index (old_type); + int new_index = type_to_cast_index (new_type); - gcc_jit_lvalue *tmp_u = - gcc_jit_function_new_local (comp.func, - NULL, - comp.cast_union_type, - format_string ("union_cast_%td", i++)); - gcc_jit_block_add_assignment (comp.block, - NULL, - gcc_jit_lvalue_access_field (tmp_u, - NULL, - orig_field), - obj); - - return gcc_jit_rvalue_access_field ( gcc_jit_lvalue_as_rvalue (tmp_u), - NULL, - dest_field); + /* Lookup the appropriate cast function in the cast matrix. */ + return gcc_jit_context_new_call (comp.ctxt, + NULL, + comp.cast_functions_from_to[old_index][new_index], + 1, &obj); } static gcc_jit_rvalue * @@ -2963,109 +2914,121 @@ define_thread_state_struct (void) gcc_jit_type_get_pointer (gcc_jit_struct_as_type (comp.thread_state_s)); } -static void -define_cast_union (void) +struct cast_type { + gcc_jit_type *type; + const char *name; + size_t bytes_size; +}; - comp.cast_union_as_ll = - gcc_jit_context_new_field (comp.ctxt, - NULL, - comp.long_long_type, - "ll"); - comp.cast_union_as_ull = - gcc_jit_context_new_field (comp.ctxt, - NULL, - comp.unsigned_long_long_type, - "ull"); - comp.cast_union_as_l = - gcc_jit_context_new_field (comp.ctxt, - NULL, - comp.long_type, - "l"); - comp.cast_union_as_ul = - gcc_jit_context_new_field (comp.ctxt, - NULL, - comp.unsigned_long_type, - "ul"); - comp.cast_union_as_u = - gcc_jit_context_new_field (comp.ctxt, - NULL, - comp.unsigned_type, - "u"); - comp.cast_union_as_i = - gcc_jit_context_new_field (comp.ctxt, - NULL, - comp.int_type, - "i"); - comp.cast_union_as_b = - gcc_jit_context_new_field (comp.ctxt, - NULL, - comp.bool_type, - "b"); - comp.cast_union_as_uintptr = - gcc_jit_context_new_field (comp.ctxt, - NULL, - comp.uintptr_type, - "uintptr"); - comp.cast_union_as_ptrdiff = - gcc_jit_context_new_field (comp.ctxt, - NULL, - comp.ptrdiff_type, - "ptrdiff"); - comp.cast_union_as_c_p = - gcc_jit_context_new_field (comp.ctxt, - NULL, - comp.char_ptr_type, - "c_p"); - comp.cast_union_as_v_p = - gcc_jit_context_new_field (comp.ctxt, - NULL, - comp.void_ptr_type, - "v_p"); - comp.cast_union_as_lisp_cons_ptr = - gcc_jit_context_new_field (comp.ctxt, - NULL, - comp.lisp_cons_ptr_type, - "cons_ptr"); - comp.cast_union_as_lisp_word = - gcc_jit_context_new_field (comp.ctxt, - NULL, - comp.lisp_word_type, - "lisp_word"); - comp.cast_union_as_lisp_word_tag = - gcc_jit_context_new_field (comp.ctxt, +static gcc_jit_function * +define_cast_from_to (struct cast_type from, int from_index, struct cast_type to, + int to_index) +{ + char *name = format_string ("cast_from_%s_to_%s", from.name, to.name); + gcc_jit_param *param = gcc_jit_context_new_param (comp.ctxt, NULL, + from.type, "arg"); + gcc_jit_function *result = gcc_jit_context_new_function (comp.ctxt, NULL, - comp.lisp_word_tag_type, - "lisp_word_tag"); - comp.cast_union_as_lisp_obj_ptr = - gcc_jit_context_new_field (comp.ctxt, - NULL, - comp.lisp_obj_ptr_type, - "lisp_obj_ptr"); - - - gcc_jit_field *cast_union_fields[] = - { comp.cast_union_as_ll, - comp.cast_union_as_ull, - comp.cast_union_as_l, - comp.cast_union_as_ul, - comp.cast_union_as_u, - comp.cast_union_as_i, - comp.cast_union_as_b, - comp.cast_union_as_uintptr, - comp.cast_union_as_ptrdiff, - comp.cast_union_as_c_p, - comp.cast_union_as_v_p, - comp.cast_union_as_lisp_cons_ptr, - comp.cast_union_as_lisp_word, - comp.cast_union_as_lisp_word_tag, - comp.cast_union_as_lisp_obj_ptr }; + GCC_JIT_FUNCTION_INTERNAL, + to.type, + name, + 1, + ¶m, + 0); + + DECL_BLOCK (entry_block, result); + + gcc_jit_lvalue *tmp_union + = gcc_jit_function_new_local (result, + NULL, + comp.cast_union_type, + "union_cast"); + + /* Zero the union first. */ + gcc_jit_block_add_assignment (entry_block, NULL, + gcc_jit_lvalue_access_field (tmp_union, NULL, + comp.cast_union_fields[NUM_CAST_TYPES]), + gcc_jit_context_new_rvalue_from_int ( + comp.ctxt, + comp.cast_types[NUM_CAST_TYPES], + 0)); + + gcc_jit_block_add_assignment (entry_block, NULL, + gcc_jit_lvalue_access_field (tmp_union, NULL, + comp.cast_union_fields[from_index]), + gcc_jit_param_as_rvalue (param)); + + gcc_jit_block_end_with_return (entry_block, + NULL, + gcc_jit_rvalue_access_field ( + gcc_jit_lvalue_as_rvalue (tmp_union), + NULL, + comp.cast_union_fields[to_index])); + + return result; +} + +static void +define_cast_functions (void) +{ + struct cast_type cast_types[NUM_CAST_TYPES] + = { { comp.bool_type, "bool", sizeof (bool) }, + { comp.char_ptr_type, "char_ptr", sizeof (char *) }, + { comp.int_type, "int", sizeof (int) }, + { comp.lisp_cons_ptr_type, "cons_ptr", sizeof (struct Lisp_Cons *) }, + { comp.lisp_obj_ptr_type, "lisp_obj_ptr", sizeof (Lisp_Object *) }, + { comp.lisp_word_tag_type, "lisp_word_tag", sizeof (Lisp_Word_tag) }, + { comp.lisp_word_type, "lisp_word", sizeof (Lisp_Word) }, + { comp.long_long_type, "long_long", sizeof (long long) }, + { comp.long_type, "long", sizeof (long) }, + { comp.ptrdiff_type, "ptrdiff", sizeof (ptrdiff_t) }, + { comp.uintptr_type, "uintptr", sizeof (uintptr_t) }, + { comp.unsigned_long_long_type, "unsigned_long_long", + sizeof (unsigned long long) }, + { comp.unsigned_long_type, "unsigned_long", sizeof (unsigned long) }, + { comp.unsigned_type, "unsigned", sizeof (unsigned) }, + { comp.void_ptr_type, "void_ptr", sizeof (void*) } }; + + /* Find the biggest size. It should be unsigned long long, but to be + sure we find it programmatically. */ + size_t biggest_size = 0; + for (int i = 0; i < NUM_CAST_TYPES; ++i) + biggest_size = max (biggest_size, cast_types[i].bytes_size); + + /* Define the union used for casting. */ + for (int i = 0; i < NUM_CAST_TYPES; ++i) + { + comp.cast_types[i] = cast_types[i].type; + comp.cast_union_fields[i] = gcc_jit_context_new_field (comp.ctxt, + NULL, + cast_types[i].type, + cast_types[i].name); + comp.cast_type_names[i] = cast_types[i].name; + comp.cast_type_sizes[i] = cast_types[i].bytes_size; + } + + gcc_jit_type *biggest_type = gcc_jit_context_get_int_type (comp.ctxt, + biggest_size, + false); + comp.cast_types[NUM_CAST_TYPES] = biggest_type; + comp.cast_union_fields[NUM_CAST_TYPES] + = gcc_jit_context_new_field (comp.ctxt, NULL, biggest_type, "biggest_type"); + comp.cast_type_names[NUM_CAST_TYPES] = "biggest_type"; + comp.cast_type_sizes[NUM_CAST_TYPES] = biggest_size; + comp.cast_union_type = gcc_jit_context_new_union_type (comp.ctxt, NULL, "cast_union", - ARRAYELTS (cast_union_fields), - cast_union_fields); + NUM_CAST_TYPES + 1, + comp.cast_union_fields); + + /* Define the cast functions using a matrix. */ + for (int i = 0; i < NUM_CAST_TYPES; ++i) + for (int j = 0; j < NUM_CAST_TYPES; ++j) + comp.cast_functions_from_to[i][j] = + define_cast_from_to (cast_types[i], i, cast_types[j], j); } static void @@ -3881,7 +3844,7 @@ DEFUN ("comp--init-ctxt", Fcomp__init_ctxt, Scomp__init_ctxt, define_jmp_buf (); define_handler_struct (); define_thread_state_struct (); - define_cast_union (); + define_cast_functions (); return Qt; } commit 516575369b7168f09030d297b5a2f89a26f1894d Author: Nicolás Bértolo Date: Sun May 31 15:55:18 2020 -0300 * Remove unnecessary DLL load of gcc_jit_block_add_assignment_op. * src/comp.c (gcc_jit_block_add_assignment_op): Remove unnecessary func import. diff --git a/src/comp.c b/src/comp.c index d8e78bc217..b6726822b7 100644 --- a/src/comp.c +++ b/src/comp.c @@ -46,7 +46,6 @@ along with GNU Emacs. If not, see . */ # include "w32common.h" #undef gcc_jit_block_add_assignment -#undef gcc_jit_block_add_assignment_op #undef gcc_jit_block_add_comment #undef gcc_jit_block_add_eval #undef gcc_jit_block_end_with_conditional @@ -201,10 +200,6 @@ DEF_DLL_FN (gcc_jit_type *, gcc_jit_type_get_pointer, (gcc_jit_type *type)); DEF_DLL_FN (void, gcc_jit_block_add_assignment, (gcc_jit_block *block, gcc_jit_location *loc, gcc_jit_lvalue *lvalue, gcc_jit_rvalue *rvalue)); -DEF_DLL_FN (void, gcc_jit_block_add_assignment_op, - (gcc_jit_block *block, gcc_jit_location *loc, - gcc_jit_lvalue *lvalue, enum gcc_jit_binary_op op, - gcc_jit_rvalue *rvalue)); DEF_DLL_FN (void, gcc_jit_block_add_eval, (gcc_jit_block *block, gcc_jit_location *loc, gcc_jit_rvalue *rvalue)); @@ -250,7 +245,6 @@ init_gccjit_functions (void) /* In alphabetical order */ LOAD_DLL_FN (library, gcc_jit_block_add_assignment); - LOAD_DLL_FN (library, gcc_jit_block_add_assignment_op); LOAD_DLL_FN (library, gcc_jit_block_add_comment); LOAD_DLL_FN (library, gcc_jit_block_add_eval); LOAD_DLL_FN (library, gcc_jit_block_end_with_conditional); @@ -312,7 +306,6 @@ init_gccjit_functions (void) /* In alphabetical order */ #define gcc_jit_block_add_assignment fn_gcc_jit_block_add_assignment -#define gcc_jit_block_add_assignment_op fn_gcc_jit_block_add_assignment_op #define gcc_jit_block_add_comment fn_gcc_jit_block_add_comment #define gcc_jit_block_add_eval fn_gcc_jit_block_add_eval #define gcc_jit_block_end_with_conditional fn_gcc_jit_block_end_with_conditional commit 2e25eebfbd25b131b6d0fcff4e60f7a8773d912b Author: Andrea Corallo Date: Sun May 31 22:26:08 2020 +0100 Store libgccjit version into generated code * src/comp.c (emit_ctxt_code): Add libgccjit version into stored optimize qualities. (syms_of_comp): Define Qgccjit here. * src/w32fns.c (syms_of_w32fns): Move out Qgccjit definition. diff --git a/src/comp.c b/src/comp.c index 2d904c9154..d8e78bc217 100644 --- a/src/comp.c +++ b/src/comp.c @@ -2634,8 +2634,10 @@ emit_ctxt_code (void) { Fcons (Qcomp_speed, Fsymbol_value (Qcomp_speed)), Fcons (Qcomp_debug, - Fsymbol_value (Qcomp_debug)) }; - emit_static_object (TEXT_OPTIM_QLY_SYM, Flist (2, opt_qly)); + Fsymbol_value (Qcomp_debug)), + Fcons (Qgccjit, + Fcomp_libgccjit_version ()) }; + emit_static_object (TEXT_OPTIM_QLY_SYM, Flist (ARRAYELTS (opt_qly), opt_qly)); emit_static_object (TEXT_FDOC_SYM, CALL1I (comp-ctxt-function-docs, Vcomp_ctxt)); @@ -4770,6 +4772,7 @@ syms_of_comp (void) DEFSYM (Qscratch, "scratch"); DEFSYM (Qlate, "late"); DEFSYM (Qlambda_fixup, "lambda-fixup"); + DEFSYM (Qgccjit, "gccjit"); /* To be signaled by the compiler. */ DEFSYM (Qnative_compiler_error, "native-compiler-error"); diff --git a/src/w32fns.c b/src/w32fns.c index eeb73489dd..e595b0285a 100644 --- a/src/w32fns.c +++ b/src/w32fns.c @@ -10462,7 +10462,6 @@ syms_of_w32fns (void) DEFSYM (Qzlib, "zlib"); DEFSYM (Qlcms2, "lcms2"); DEFSYM (Qjson, "json"); - DEFSYM (Qgccjit, "gccjit"); Fput (Qundefined_color, Qerror_conditions, pure_list (Qundefined_color, Qerror)); commit ce3c1ea83e18e6b8a02013bbdae4b4c183e39997 Author: Andrea Corallo Date: Sun May 31 20:28:31 2020 +0100 * Optimize 'emit_static_object' for load-time * src/comp.c (emit_static_object): Use a chunck size of 200 bytes on bugged GCCs and a longer one (1024) in sane ones. Rename str in buff to disambiguate and prefer xmalloc to a VLA given the buffer is not that small. diff --git a/src/comp.c b/src/comp.c index c9d3fd0407..2d904c9154 100644 --- a/src/comp.c +++ b/src/comp.c @@ -2441,27 +2441,30 @@ emit_static_object (const char *name, Lisp_Object obj) gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.int_type, 0)), NULL)); + /* We can't use always string literals longer that 200 bytes because + they cause a crash in pre GCC 10 libgccjit. + . + + Adjust if possible to reduce the number of function calls. */ + size_t chunck_size = NILP (Fcomp_libgccjit_version ()) ? 200 : 1024; + char *buff = xmalloc (chunck_size); for (ptrdiff_t i = 0; i < len;) { - /* We can't use string literals longer that 200 bytes because - they cause a crash in older versions of gccjit. - https://gcc.gnu.org/ml/jit/2019-q3/msg00013.html. */ - char str[200]; - strncpy (str, p, 200); - str[199] = 0; - uintptr_t l = strlen (str); + strncpy (buff, p, chunck_size); + buff[chunck_size - 1] = 0; + uintptr_t l = strlen (buff); if (l != 0) { p += l; i += l; - gcc_jit_rvalue *args[3] - = {gcc_jit_lvalue_as_rvalue (ptrvar), - gcc_jit_context_new_string_literal (comp.ctxt, str), - gcc_jit_context_new_rvalue_from_int (comp.ctxt, - comp.size_t_type, - l)}; + gcc_jit_rvalue *args[] = + { gcc_jit_lvalue_as_rvalue (ptrvar), + gcc_jit_context_new_string_literal (comp.ctxt, buff), + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.size_t_type, + l) }; gcc_jit_block_add_eval (block, NULL, gcc_jit_context_new_call (comp.ctxt, NULL, @@ -2496,6 +2499,7 @@ emit_static_object (const char *name, Lisp_Object obj) NULL)); } } + xfree (buff); gcc_jit_block_add_assignment ( block, commit c936e028c643dc2629e6d2041f2069d89d8c5877 Author: Andrea Corallo Date: Sun May 31 20:47:50 2020 +0100 * Add `comp-libgccjit-version' subr * src/comp.c (gcc_jit_version_major, gcc_jit_version_minor) (gcc_jit_version_patchlevel): Import. (Fcomp_libgccjit_version): New Lisp function. (syms_of_comp): Update for 'comp-libgccjit-version'. diff --git a/src/comp.c b/src/comp.c index 81c4d2fe32..c9d3fd0407 100644 --- a/src/comp.c +++ b/src/comp.c @@ -236,6 +236,9 @@ DEF_DLL_FN (void, gcc_jit_context_set_logfile, DEF_DLL_FN (void, gcc_jit_struct_set_fields, (gcc_jit_struct *struct_type, gcc_jit_location *loc, int num_fields, gcc_jit_field **fields)); +DEF_DLL_FN (int, gcc_jit_version_major); +DEF_DLL_FN (int, gcc_jit_version_minor); +DEF_DLL_FN (int, gcc_jit_version_patchlevel); static bool init_gccjit_functions (void) @@ -300,6 +303,9 @@ init_gccjit_functions (void) LOAD_DLL_FN (library, gcc_jit_struct_as_type); LOAD_DLL_FN (library, gcc_jit_struct_set_fields); LOAD_DLL_FN (library, gcc_jit_type_get_pointer); + LOAD_DLL_FN (library, gcc_jit_version_major); + LOAD_DLL_FN (library, gcc_jit_version_minor); + LOAD_DLL_FN (library, gcc_jit_version_patchlevel); return true; } @@ -3988,6 +3994,29 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, return out_file; } +DEFUN ("comp-libgccjit-version", Fcomp_libgccjit_version, + Scomp_libgccjit_version, 0, 0, 0, + doc: /* Return the libgccjit version in use in the form +(MAJOR MINOR PATCHLEVEL) or nil if unknown (pre GCC10). */) + (void) +{ +#if defined (LIBGCCJIT_HAVE_gcc_jit_version) || defined (WINDOWSNT) + load_gccjit_if_necessary (true); + + /* FIXME this kludge is quite bad. Can we dynamically load on all + operating systems? */ +#pragma GCC diagnostic ignored "-Waddress" + return gcc_jit_version_major + ? list3 (make_fixnum (gcc_jit_version_major ()), + make_fixnum (gcc_jit_version_minor ()), + make_fixnum (gcc_jit_version_patchlevel ())) + : Qnil; +#pragma GCC diagnostic pop +#else + return Qnil; +#endif +} + /******************************************************************************/ /* Helper functions called from the run-time. */ @@ -4781,6 +4810,7 @@ syms_of_comp (void) defsubr (&Scomp__init_ctxt); defsubr (&Scomp__release_ctxt); defsubr (&Scomp__compile_ctxt_to_file); + defsubr (&Scomp_libgccjit_version); defsubr (&Scomp__register_lambda); defsubr (&Scomp__register_subr); defsubr (&Scomp__late_register_subr); commit 15d4fee69fa637191ed985af2397e732001dab6f Merge: 3efb2808d4 f56830acbf Author: Andrea Corallo Date: Sun May 31 18:32:13 2020 +0100 Merge remote-tracking branch 'savannah/master' into HEAD commit 3efb2808d415f723ade4a0f9f61738e1a707156c Author: Nicolás Bértolo Date: Wed May 20 00:34:32 2020 -0300 * Cut down compile-time emitting static data as string literals This change drastically reduce compile time. Apparently GCC optimizer does not scale up well at all for long sequences of assignments into a single array. Nicolás Bértolo Andrea Corallo * src/comp.c (gcc_jit_context_new_string_literal) (gcc_jit_block_add_assignment_op): New imports. (comp_t): New 'size_t_type' 'memcpy' fields. (emit_static_object): Define static objects using string literals and memcpy. (define_memcpy): New function. (Fcomp__init_ctxt): Define 'size_t_type' and 'memcpy'. diff --git a/src/comp.c b/src/comp.c index f288fc2551..81c4d2fe32 100644 --- a/src/comp.c +++ b/src/comp.c @@ -46,6 +46,7 @@ along with GNU Emacs. If not, see . */ # include "w32common.h" #undef gcc_jit_block_add_assignment +#undef gcc_jit_block_add_assignment_op #undef gcc_jit_block_add_comment #undef gcc_jit_block_add_eval #undef gcc_jit_block_end_with_conditional @@ -75,6 +76,7 @@ along with GNU Emacs. If not, see . */ #undef gcc_jit_context_new_rvalue_from_int #undef gcc_jit_context_new_rvalue_from_long #undef gcc_jit_context_new_rvalue_from_ptr +#undef gcc_jit_context_new_string_literal #undef gcc_jit_context_new_struct_type #undef gcc_jit_context_new_unary_op #undef gcc_jit_context_new_union_type @@ -164,6 +166,8 @@ DEF_DLL_FN (gcc_jit_rvalue *, gcc_jit_context_new_rvalue_from_long, (gcc_jit_context *ctxt, gcc_jit_type *numeric_type, long value)); DEF_DLL_FN (gcc_jit_rvalue *, gcc_jit_context_new_rvalue_from_ptr, (gcc_jit_context *ctxt, gcc_jit_type *pointer_type, void *value)); +DEF_DLL_FN (gcc_jit_rvalue *, gcc_jit_context_new_string_literal, + (gcc_jit_context *ctxt, const char *value)); DEF_DLL_FN (gcc_jit_rvalue *, gcc_jit_context_new_unary_op, (gcc_jit_context *ctxt, gcc_jit_location *loc, enum gcc_jit_unary_op op, gcc_jit_type *result_type, @@ -197,6 +201,10 @@ DEF_DLL_FN (gcc_jit_type *, gcc_jit_type_get_pointer, (gcc_jit_type *type)); DEF_DLL_FN (void, gcc_jit_block_add_assignment, (gcc_jit_block *block, gcc_jit_location *loc, gcc_jit_lvalue *lvalue, gcc_jit_rvalue *rvalue)); +DEF_DLL_FN (void, gcc_jit_block_add_assignment_op, + (gcc_jit_block *block, gcc_jit_location *loc, + gcc_jit_lvalue *lvalue, enum gcc_jit_binary_op op, + gcc_jit_rvalue *rvalue)); DEF_DLL_FN (void, gcc_jit_block_add_eval, (gcc_jit_block *block, gcc_jit_location *loc, gcc_jit_rvalue *rvalue)); @@ -239,6 +247,7 @@ init_gccjit_functions (void) /* In alphabetical order */ LOAD_DLL_FN (library, gcc_jit_block_add_assignment); + LOAD_DLL_FN (library, gcc_jit_block_add_assignment_op); LOAD_DLL_FN (library, gcc_jit_block_add_comment); LOAD_DLL_FN (library, gcc_jit_block_add_eval); LOAD_DLL_FN (library, gcc_jit_block_end_with_conditional); @@ -268,6 +277,7 @@ init_gccjit_functions (void) LOAD_DLL_FN (library, gcc_jit_context_new_rvalue_from_int); LOAD_DLL_FN (library, gcc_jit_context_new_rvalue_from_long); LOAD_DLL_FN (library, gcc_jit_context_new_rvalue_from_ptr); + LOAD_DLL_FN (library, gcc_jit_context_new_string_literal); LOAD_DLL_FN (library, gcc_jit_context_new_struct_type); LOAD_DLL_FN (library, gcc_jit_context_new_unary_op); LOAD_DLL_FN (library, gcc_jit_context_new_union_type); @@ -296,6 +306,7 @@ init_gccjit_functions (void) /* In alphabetical order */ #define gcc_jit_block_add_assignment fn_gcc_jit_block_add_assignment +#define gcc_jit_block_add_assignment_op fn_gcc_jit_block_add_assignment_op #define gcc_jit_block_add_comment fn_gcc_jit_block_add_comment #define gcc_jit_block_add_eval fn_gcc_jit_block_add_eval #define gcc_jit_block_end_with_conditional fn_gcc_jit_block_end_with_conditional @@ -325,6 +336,7 @@ init_gccjit_functions (void) #define gcc_jit_context_new_rvalue_from_int fn_gcc_jit_context_new_rvalue_from_int #define gcc_jit_context_new_rvalue_from_long fn_gcc_jit_context_new_rvalue_from_long #define gcc_jit_context_new_rvalue_from_ptr fn_gcc_jit_context_new_rvalue_from_ptr +#define gcc_jit_context_new_string_literal fn_gcc_jit_context_new_string_literal #define gcc_jit_context_new_struct_type fn_gcc_jit_context_new_struct_type #define gcc_jit_context_new_unary_op fn_gcc_jit_context_new_unary_op #define gcc_jit_context_new_union_type fn_gcc_jit_context_new_union_type @@ -462,6 +474,7 @@ typedef struct { gcc_jit_type *char_ptr_type; gcc_jit_type *ptrdiff_type; gcc_jit_type *uintptr_type; + gcc_jit_type *size_t_type; #if LISP_WORDS_ARE_POINTERS gcc_jit_type *lisp_X; #endif @@ -548,6 +561,7 @@ typedef struct { gcc_jit_rvalue *data_relocs_ephemeral; /* Synthesized struct holding func relocs. */ gcc_jit_lvalue *func_relocs; + gcc_jit_function *memcpy; Lisp_Object d_default_idx; Lisp_Object d_impure_idx; Lisp_Object d_ephemeral_idx; @@ -2347,7 +2361,7 @@ emit_static_object (const char *name, Lisp_Object obj) /* libgccjit has no support for initialized static data. The mechanism below is certainly not aesthetic but I assume the bottle neck in terms of performance at load time will still be the reader. - NOTE: we can not relay on libgccjit even for valid NULL terminated C + NOTE: we can not rely on libgccjit even for valid NULL terminated C strings cause of this funny bug that will affect all pre gcc10 era gccs: https://gcc.gnu.org/ml/jit/2019-q3/msg00013.html */ @@ -2405,22 +2419,78 @@ emit_static_object (const char *name, Lisp_Object obj) gcc_jit_lvalue *arr = gcc_jit_lvalue_access_field (data_struct, NULL, fields[1]); - for (ptrdiff_t i = 0; i < len; i++, p++) + gcc_jit_lvalue *ptrvar = gcc_jit_function_new_local (f, NULL, + comp.char_ptr_type, + "ptr"); + + gcc_jit_block_add_assignment ( + block, + NULL, + ptrvar, + gcc_jit_lvalue_get_address ( + gcc_jit_context_new_array_access ( + comp.ctxt, + NULL, + gcc_jit_lvalue_as_rvalue (arr), + gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.int_type, 0)), + NULL)); + + for (ptrdiff_t i = 0; i < len;) { - gcc_jit_block_add_assignment ( - block, - NULL, - gcc_jit_context_new_array_access ( - comp.ctxt, - NULL, - gcc_jit_lvalue_as_rvalue (arr), - gcc_jit_context_new_rvalue_from_int (comp.ctxt, - comp.ptrdiff_type, - i)), - gcc_jit_context_new_rvalue_from_int (comp.ctxt, - comp.char_type, - *p)); + /* We can't use string literals longer that 200 bytes because + they cause a crash in older versions of gccjit. + https://gcc.gnu.org/ml/jit/2019-q3/msg00013.html. */ + char str[200]; + strncpy (str, p, 200); + str[199] = 0; + uintptr_t l = strlen (str); + + if (l != 0) + { + p += l; + i += l; + + gcc_jit_rvalue *args[3] + = {gcc_jit_lvalue_as_rvalue (ptrvar), + gcc_jit_context_new_string_literal (comp.ctxt, str), + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.size_t_type, + l)}; + + gcc_jit_block_add_eval (block, NULL, + gcc_jit_context_new_call (comp.ctxt, NULL, + comp.memcpy, + ARRAYELTS (args), + args)); + gcc_jit_block_add_assignment (block, NULL, ptrvar, + gcc_jit_lvalue_get_address ( + gcc_jit_context_new_array_access (comp.ctxt, NULL, + gcc_jit_lvalue_as_rvalue (ptrvar), + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.uintptr_type, + l)), + NULL)); + } + else + { + /* If strlen returned 0 that means that the static object + contains a NULL byte. In that case just move over to the + next block. We can rely on the byte being zero because + of the previous call to bzero and because the dynamic + linker cleared it. */ + p++; + i++; + gcc_jit_block_add_assignment ( + block, NULL, ptrvar, + gcc_jit_lvalue_get_address ( + gcc_jit_context_new_array_access ( + comp.ctxt, NULL, gcc_jit_lvalue_as_rvalue (ptrvar), + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.uintptr_type, 1)), + NULL)); + } } + gcc_jit_block_add_assignment ( block, NULL, @@ -2766,6 +2836,21 @@ define_jmp_buf (void) 1, &field); } +static void +define_memcpy (void) +{ + + gcc_jit_param *params[] = + { gcc_jit_context_new_param (comp.ctxt, NULL, comp.void_ptr_type, "dest"), + gcc_jit_context_new_param (comp.ctxt, NULL, comp.void_ptr_type, "src"), + gcc_jit_context_new_param (comp.ctxt, NULL, comp.size_t_type, "n") }; + + comp.memcpy = + gcc_jit_context_new_function (comp.ctxt, NULL, GCC_JIT_FUNCTION_IMPORTED, + comp.void_ptr_type, "memcpy", + ARRAYELTS (params), params, false); +} + /* struct handler definition */ static void @@ -3772,6 +3857,9 @@ DEFUN ("comp--init-ctxt", Fcomp__init_ctxt, Scomp__init_ctxt, comp.uintptr_type = gcc_jit_context_get_int_type (comp.ctxt, sizeof (void *), false); + comp.size_t_type = gcc_jit_context_get_int_type (comp.ctxt, + sizeof (size_t), + false); comp.exported_funcs_h = CALLN (Fmake_hash_table, QCtest, Qequal); /* @@ -3780,6 +3868,8 @@ DEFUN ("comp--init-ctxt", Fcomp__init_ctxt, Scomp__init_ctxt, */ comp.imported_funcs_h = CALLN (Fmake_hash_table); + define_memcpy (); + /* Define data structures. */ define_lisp_cons (); commit 5cf148cfef23b827629950048dab678f3b9af2d3 Author: Andrea Corallo Date: Sun May 31 12:22:46 2020 +0100 * Emit better debug comments in emit_static_object * src/comp.c (emit_static_object): Do not truncate debug comments at the first NULL character. diff --git a/src/comp.c b/src/comp.c index d3bff1e4cf..f288fc2551 100644 --- a/src/comp.c +++ b/src/comp.c @@ -2392,8 +2392,15 @@ emit_static_object (const char *name, Lisp_Object obj) 0, NULL, 0); DECL_BLOCK (block, f); - /* NOTE this truncates if the data has some zero byte before termination. */ - gcc_jit_block_add_comment (block, NULL, p); + if (COMP_DEBUG > 1) + { + char *comment = memcpy (xmalloc (len), p, len); + for (ptrdiff_t i = 0; i < len - 1; i++) + if (!comment[i]) + comment[i] = '\n'; + gcc_jit_block_add_comment (block, NULL, comment); + xfree (comment); + } gcc_jit_lvalue *arr = gcc_jit_lvalue_access_field (data_struct, NULL, fields[1]); commit b818a49f667a77b7627c678fb4a2ca014f43695e Author: Nicolás Bértolo Date: Fri May 29 21:08:37 2020 -0300 Fix loading of libgccjit.dll while dumping in Windows. loadup.el calls `native-comp-available-p', that calls load_gccjit_if_necessary() in Windows. That function tries to load libgccjit using the mappings defined in `dynamic-library-alist'. That mapping is filled by term/w32-win.el, but that file may be loaded too late. * src/emacs.c (syms_of_emacs): Add libgccjit to the `dynamic-library-alist' used when starting to dump so `native-comp-available-p' always works in Windows. diff --git a/src/emacs.c b/src/emacs.c index cd4f7a0b28..8ecf9b4aeb 100644 --- a/src/emacs.c +++ b/src/emacs.c @@ -3052,7 +3052,18 @@ because they do not depend on external libraries and are always available. Also note that this is not a generic facility for accessing external libraries; only those already known by Emacs will be loaded. */); +#ifdef WINDOWSNT + /* We may need to load libgccjit when dumping before term/w32-win.el + defines `dynamic-library-alist`. This will fail if that variable + is empty, so add libgccjit.dll to it. */ + if (will_dump_p ()) + Vdynamic_library_alist = list1 (list2 (Qgccjit, + build_string ("libgccjit.dll"))); + else + Vdynamic_library_alist = Qnil; +#else Vdynamic_library_alist = Qnil; +#endif Fput (intern_c_string ("dynamic-library-alist"), Qrisky_local_variable, Qt); #ifdef WINDOWSNT commit bb9c0188ea3881a555415de7e6fe7973911719e9 Author: Nicolás Bértolo Date: Fri May 29 21:03:00 2020 -0300 Do not call `gensym' too early when loading a dump file. This happened when subr.eln was not the first native compilation unit to be loaded. register_native_comp_unit() is called when loading a native compilation unit and that in turn used to call `gensym', which was not loaded yet. This led to a SIGSEGV. * src/comp.c (register_native_comp_unit): Replace the call to `gensym' with an ad-hoc counter. diff --git a/src/comp.c b/src/comp.c index 32a98173d5..d3bff1e4cf 100644 --- a/src/comp.c +++ b/src/comp.c @@ -4120,7 +4120,12 @@ static void register_native_comp_unit (Lisp_Object comp_u) { #ifdef WINDOWSNT - Fputhash (CALL1I (gensym, Qnil), comp_u, all_loaded_comp_units_h); + /* We have to do this since we can't use `gensym'. This function is + called early when loading a dump file and subr.el may not have + been loaded yet. */ + static intmax_t count; + + Fputhash (make_int (count++), comp_u, all_loaded_comp_units_h); #endif } commit eeebbd5fcbdf2827689311b3751437670bfc2e22 Merge: 15c121ee0b f42db4b6e1 Author: Andrea Corallo Date: Sat May 30 11:52:27 2020 +0100 Merge remote-tracking branch 'savannah/master' into HEAD commit 15c121ee0b5cbe005548eeba09dd54b145b2e258 Author: Andrea Corallo Date: Sat May 30 11:13:38 2020 +0100 * Avoid calling Ffile_exists_p too early Being quite early in startup initialization is better not to rely on Ffile_exists_p, this call Ffile_expand and not all the necessary initialization already happened. * src/pdumper.c (dump_do_dump_relocation): Use fopen instead of Ffile_exists_p. diff --git a/src/pdumper.c b/src/pdumper.c index b40a29c02a..19dbacca89 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -5301,17 +5301,25 @@ dump_do_dump_relocation (const uintptr_t dump_base, if (!CONSP (comp_u->file)) error ("Trying to load incoherent dumped .eln"); + /* Check just once if this is a local build or Emacs was installed. */ if (installation_state == UNKNOWN) - /* Check just once if is a local build or Emacs got installed. */ - installation_state = - NILP (Ffile_exists_p (concat2 (Vinvocation_directory, - XCAR (comp_u->file)))) - ? LOCAL_BUILD : INSTALLED; + { + char *fname = SSDATA (concat2 (Vinvocation_directory, + XCAR (comp_u->file))); + FILE *file; + if ((file = fopen (fname, "r"))) + { + fclose (file); + installation_state = INSTALLED; + } + else + installation_state = LOCAL_BUILD; + } comp_u->file = concat2 (Vinvocation_directory, - installation_state == LOCAL_BUILD - ? XCDR (comp_u->file) : XCAR (comp_u->file)); + installation_state == INSTALLED + ? XCAR (comp_u->file) : XCDR (comp_u->file)); #ifdef WINDOWSNT comp_u->cfile = xlispstrdup (comp_u->file); #endif commit 3fa73fa0fb1caedd10553d9f3185635c039319fd Author: Andrea Corallo Date: Mon May 25 20:14:24 2020 +0100 Add a compiler hint test Test that compiler hints are executed transparently. * test/src/comp-tests.el (comp-tests-type-hints): New test. * test/src/comp-test-funcs.el (comp-tests-hint-fixnum-f) (comp-tests-hint-cons-f): New functions. diff --git a/test/src/comp-test-funcs.el b/test/src/comp-test-funcs.el index 9fcc132b51..5e04be4459 100644 --- a/test/src/comp-test-funcs.el +++ b/test/src/comp-test-funcs.el @@ -50,6 +50,12 @@ (defun comp-tests-cons-cdr-f (x) (cdr (cons 'foo x))) +(defun comp-tests-hint-fixnum-f (n) + (1+ (comp-hint-fixnum n))) + +(defun comp-tests-hint-cons-f (c) + (car (comp-hint-cons c))) + (defun comp-tests-varset0-f () (setq comp-tests-var1 55)) (defun comp-tests-varset1-f () diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index c07c92a106..3e40dba10b 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -194,6 +194,12 @@ Check that the resulting binaries do not differ." (should-error (comp-tests-fixnum-minus-f 'a) :type 'wrong-type-argument)) +(ert-deftest comp-tests-type-hints () + "Just test compiler hints are transparent in this case." + ;; FIXME we should really check they are also effective. + (should (= (comp-tests-hint-fixnum-f 3) 4)) + (should (= (comp-tests-hint-cons-f (cons 1 2)) 1))) + (ert-deftest comp-tests-arith-comp () "Testing arithmetic comparisons." (should (eq (comp-tests-eqlsign-f 4 3) nil)) commit f28b1780c6d5ed974e414a423cef8d11ed8145e6 Author: Andrea Corallo Date: Mon May 25 20:27:46 2020 +0100 * Split type hint pass from dead code removal pass into dedicated one. Given SSA prop overwrite mvar type slot we clean-up the compiler type hints as last. * lisp/emacs-lisp/comp.el (comp-passes): Add comp-remove-type-hints. (comp-remove-type-hints-func): Code move. (comp-dead-code): Do not call `comp-remove-type-hints-func'. (comp-remove-type-hints): Add as new pass. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 02917cb9a0..11539761d1 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -167,6 +167,7 @@ Can be one of: 'd-default', 'd-impure' or 'd-ephemeral'. See `comp-ctxt'.") comp-dead-code comp-tco comp-propagate-alloc + comp-remove-type-hints comp-final) "Passes to be executed in order.") @@ -2089,18 +2090,6 @@ Return the list of m-var ids nuked." insn)))))) nuke-list))) -(defun comp-remove-type-hints-func () - "Remove type hints from the current function. -These are substituted with a normal 'set' op." - (cl-loop - for b being each hash-value of (comp-func-blocks comp-func) - do (cl-loop - for insn-cell on (comp-block-insns b) - for insn = (car insn-cell) - do (pcase insn - (`(set ,l-val (call ,(pred comp-type-hint-p) ,r-val)) - (setcar insn-cell `(set ,l-val ,r-val))))))) - (defun comp-dead-code (_) "Dead code elimination." (when (>= comp-speed 2) @@ -2112,9 +2101,7 @@ These are substituted with a normal 'set' op." for i from 1 while (comp-dead-assignments-func) finally (comp-log (format "dead code rm run %d times\n" i) 2) - (comp-log-func comp-func 3)) - (comp-remove-type-hints-func) - (comp-log-func comp-func 3)))) + (comp-log-func comp-func 3))))) (comp-ctxt-funcs-h comp-ctxt)))) @@ -2156,6 +2143,33 @@ These are substituted with a normal 'set' op." (comp-log-func comp-func 3)))) (comp-ctxt-funcs-h comp-ctxt)))) + +;;; Type hint removal pass specific code. + +;; This must run after all SSA prop not to have the type hint +;; information overwritten. + +(defun comp-remove-type-hints-func () + "Remove type hints from the current function. +These are substituted with a normal 'set' op." + (cl-loop + for b being each hash-value of (comp-func-blocks comp-func) + do (cl-loop + for insn-cell on (comp-block-insns b) + for insn = (car insn-cell) + do (pcase insn + (`(set ,l-val (call ,(pred comp-type-hint-p) ,r-val)) + (setcar insn-cell `(set ,l-val ,r-val))))))) + +(defun comp-remove-type-hints (_) + "Dead code elimination." + (when (>= comp-speed 2) + (maphash (lambda (_ f) + (let ((comp-func f)) + (comp-remove-type-hints-func) + (comp-log-func comp-func 3))) + (comp-ctxt-funcs-h comp-ctxt)))) + ;;; Final pass specific code. commit b478d57e73ccff63788de805bfe178481ff084cf Merge: 2bc41e0963 c812223c9f Author: Andrea Corallo Date: Mon May 25 15:56:25 2020 +0100 Merge remote-tracking branch 'savannah/master' into HEAD commit 2bc41e0963275e77ca3627fbfd754fcc041405cb Author: Andrea Corallo Date: Sun May 24 22:49:38 2020 +0100 ; Ease ifdef navigation in native-comp files * src/comp.c (syms_of_comp): Add a comment to ease #endif understading. * src/comp.h: Likewise. diff --git a/src/comp.c b/src/comp.c index b4e3e2e887..32a98173d5 100644 --- a/src/comp.c +++ b/src/comp.c @@ -4722,7 +4722,8 @@ syms_of_comp (void) doc: /* Hash table symbol-name -> function-value. For internal use during */); Vcomp_deferred_pending_h = CALLN (Fmake_hash_table, QCtest, Qeq); -#endif + +#endif /* #ifdef HAVE_NATIVE_COMP */ defsubr (&Snative_comp_available_p); } diff --git a/src/comp.h b/src/comp.h index c6f23dc146..1f64a6df55 100644 --- a/src/comp.h +++ b/src/comp.h @@ -100,7 +100,8 @@ extern void finish_delayed_disposal_of_comp_units (void); extern void dispose_all_remaining_comp_units (void); extern void clean_package_user_dir_of_old_comp_units (void); -#else + +#else /* #ifdef HAVE_NATIVE_COMP */ static inline void maybe_defer_native_compilation (Lisp_Object function_name, @@ -127,6 +128,6 @@ static inline void finish_delayed_disposal_of_comp_units (void) {} -#endif +#endif /* #ifdef HAVE_NATIVE_COMP */ -#endif +#endif /* #ifndef COMP_H */ commit 0bba0e367b4b5378501de7c91838ea2de8b4af4a Author: Andrea Corallo Date: Sun May 24 21:59:25 2020 +0100 Fix GNU style * src/comp.h: Fix GNU style. * src/comp.c (Fcomp__compile_ctxt_to_file): Likewise. * lisp/emacs-lisp/comp.el (comp--replace-output-file): Likewise. * src/pdumper.c (dump_do_dump_relocation): Likewise. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 3845827f66..02917cb9a0 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2278,8 +2278,9 @@ Prepare every function for final compilation and drive the C back-end." ;; Some entry point support code. (defun comp--replace-output-file (outfile tmpfile) - "Replace OUTFILE with TMPFILE taking the necessary steps when -dealing with shared libraries that may be loaded into Emacs" + "Replace OUTFILE with TMPFILE. +Takes the necessary steps when dealing with shared libraries that +may be loaded into Emacs" (cond ((eq 'windows-nt system-type) (ignore-errors (delete-file outfile)) (let ((retry t)) diff --git a/src/comp.c b/src/comp.c index 16ad77c74b..b4e3e2e887 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3883,7 +3883,7 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, GCC_JIT_OUTPUT_KIND_DYNAMIC_LIBRARY, SSDATA (tmp_file)); - CALL2I(comp--replace-output-file, out_file, tmp_file); + CALL2I (comp--replace-output-file, out_file, tmp_file); if (!noninteractive) unbind_to (count, Qnil); @@ -3953,67 +3953,68 @@ helper_PSEUDOVECTOR_TYPEP_XUNTAG (Lisp_Object a, enum pvec_type code) /*********************************/ /* -The problem: Windows does not let us delete an .eln file that has been -loaded by a process. This has two implications in Emacs: + The problem: Windows does not let us delete an .eln file that has + been loaded by a process. This has two implications in Emacs: -1) It is not possible to recompile a lisp file if the corresponding -.eln file has been loaded. This is because we'd like to use the same -filename, but we can't delete the old .eln file. + 1) It is not possible to recompile a lisp file if the corresponding + .eln file has been loaded. This is because we'd like to use the same + filename, but we can't delete the old .eln file. -2) It is not possible to delete a package using `package-delete' -if an .eln file has been loaded. + 2) It is not possible to delete a package using `package-delete' + if an .eln file has been loaded. -* General idea + * General idea -The solution to these two problems is to move the foo.eln file -somewhere else and have the last Emacs instance using it delete it. -To make it easy to find what files need to be removed we use two approaches. + The solution to these two problems is to move the foo.eln file + somewhere else and have the last Emacs instance using it delete it. + To make it easy to find what files need to be removed we use two approaches. -In the 1) case we rename foo.eln to fooXXXXXX.eln.old in the same -folder. When Emacs is unloading "foo" (either GC'd the native -compilation unit or Emacs is closing (see below)) we delete all the -.eln.old files in the folder where the original foo.eln was stored. + In the 1) case we rename foo.eln to fooXXXXXX.eln.old in the same + folder. When Emacs is unloading "foo" (either GC'd the native + compilation unit or Emacs is closing (see below)) we delete all the + .eln.old files in the folder where the original foo.eln was stored. -Ideally we'd figure out the new name of foo.eln and delete it if -it ends in .eln.old. There is no simple API to do this in -Windows. GetModuleFileName() returns the original filename, not the -current one. This forces us to put .eln.old files in an agreed upon -path. We cannot use %TEMP% because it may be in another drive and then -the rename operation would fail. + Ideally we'd figure out the new name of foo.eln and delete it if it + ends in .eln.old. There is no simple API to do this in Windows. + GetModuleFileName () returns the original filename, not the current + one. This forces us to put .eln.old files in an agreed upon path. + We cannot use %TEMP% because it may be in another drive and then the + rename operation would fail. -In the 2) case we can't use the same folder where the .eln file -resided, as we are trying to completely remove the package. Since we -are removing packages we can safely move the .eln.old file to -`package-user-dir' as we are sure that that would not mean changing -drives. + In the 2) case we can't use the same folder where the .eln file + resided, as we are trying to completely remove the package. Since we + are removing packages we can safely move the .eln.old file to + `package-user-dir' as we are sure that that would not mean changing + drives. -* Implementation details + * Implementation details -The concept of disposal of a native compilation unit refers to -unloading the shared library and deleting all the .eln.old files in -the directory. These are two separate steps. We'll call them -early-disposal and late-disposal. + The concept of disposal of a native compilation unit refers to + unloading the shared library and deleting all the .eln.old files in + the directory. These are two separate steps. We'll call them + early-disposal and late-disposal. -There are two data structures used: + There are two data structures used: -- The `all_loaded_comp_units_h` hashtable. + - The `all_loaded_comp_units_h` hashtable. -This hashtable is used like an array of weak references to native -compilation units. This hash table is filled by load_comp_unit() and -dispose_all_remaining_comp_units() iterates over all values that were -not disposed by the GC and performs all disposal steps when Emacs is -closing. + This hashtable is used like an array of weak references to native + compilation units. This hash table is filled by load_comp_unit () + and dispose_all_remaining_comp_units () iterates over all values + that were not disposed by the GC and performs all disposal steps + when Emacs is closing. -- The `delayed_comp_unit_disposal_list` list. + - The `delayed_comp_unit_disposal_list` list. -This is were the dispose_comp_unit() function, when called by the GC -sweep stage, stores the original filenames of the disposed native -compilation units. This is an ad-hoc C structure instead of a Lisp -cons because we need to allocate instances of this structure during -the GC. + This is were the dispose_comp_unit () function, when called by the + GC sweep stage, stores the original filenames of the disposed native + compilation units. This is an ad-hoc C structure instead of a Lisp + cons because we need to allocate instances of this structure during + the GC. -The finish_delayed_disposal_of_comp_units() function will iterate over -this list and perform the late-disposal step when Emacs is closing. + The finish_delayed_disposal_of_comp_units () function will iterate + over this list and perform the late-disposal step when Emacs is + closing. */ @@ -4022,9 +4023,8 @@ this list and perform the late-disposal step when Emacs is closing. static Lisp_Object all_loaded_comp_units_h; -/* We need to allocate instances of this struct during a GC - * sweep. This is why it can't be transformed into a simple cons. - */ +/* We need to allocate instances of this struct during a GC sweep. + This is why it can't be transformed into a simple cons. */ struct delayed_comp_unit_disposal { struct delayed_comp_unit_disposal *next; @@ -4041,9 +4041,8 @@ return_nil (Lisp_Object arg) /* Tries to remove all *.eln.old files in DIRNAME. - * Any error is ignored because it may be due to the file being loaded - * in another Emacs instance. - */ + Any error is ignored because it may be due to the file being loaded + in another Emacs instance. */ static void clean_comp_unit_directory (Lisp_Object dirpath) { @@ -4058,9 +4057,8 @@ clean_comp_unit_directory (Lisp_Object dirpath) /* Tries to remove all *.eln.old files in `package-user-dir'. - * This is called when Emacs is closing to clean any *.eln left from a - * deleted package. - */ + This is called when Emacs is closing to clean any *.eln left from a + deleted package. */ void clean_package_user_dir_of_old_comp_units (void) { @@ -4073,10 +4071,10 @@ clean_package_user_dir_of_old_comp_units (void) } /* This function disposes all compilation units that are still loaded. - * It is important that this function is called only right before - * Emacs is closed, otherwise we risk running a subr that is - * implemented in an unloaded dynamic library. - */ + + It is important that this function is called only right before + Emacs is closed, otherwise we risk running a subr that is + implemented in an unloaded dynamic library. */ void dispose_all_remaining_comp_units (void) { @@ -4095,11 +4093,10 @@ dispose_all_remaining_comp_units (void) } /* This function finishes the disposal of compilation units that were - * passed to `dispose_comp_unit` with DELAY == true. - * - * This function is called when Emacs is idle and when it is about to - * close. - */ + passed to `dispose_comp_unit` with DELAY == true. + + This function is called when Emacs is idle and when it is about to + close. */ void finish_delayed_disposal_of_comp_units (void) { @@ -4118,8 +4115,7 @@ finish_delayed_disposal_of_comp_units (void) #endif /* This function puts the compilation unit in the - * `all_loaded_comp_units_h` hashmap. - */ + `all_loaded_comp_units_h` hashmap. */ static void register_native_comp_unit (Lisp_Object comp_u) { @@ -4128,14 +4124,13 @@ register_native_comp_unit (Lisp_Object comp_u) #endif } -/* This function disposes compilation units. It is called during the GC sweep - * stage and when Emacs is closing. +/* This function disposes compilation units. It is called during the GC sweep + stage and when Emacs is closing. - * On Windows the the DELAY parameter specifies whether the native - * compilation file will be deleted right away (if necessary) or put - * on a list. That list will be dealt with by - * `finish_delayed_disposal_of_comp_units`. - */ + On Windows the the DELAY parameter specifies whether the native + compilation file will be deleted right away (if necessary) or put + on a list. That list will be dealt with by + `finish_delayed_disposal_of_comp_units`. */ void dispose_comp_unit (struct Lisp_Native_Comp_Unit *comp_handle, bool delay) { @@ -4387,10 +4382,10 @@ load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u, bool loading_dump, data_imp_relocs[i] = AREF (comp_u->data_impure_vec, i); /* If we register them while dumping we will get some entries in - the hash table that will be duplicated when pdumper calls - load_comp_unit. */ + the hash table that will be duplicated when pdumper calls + load_comp_unit. */ if (!will_dump_p ()) - register_native_comp_unit (comp_u_lisp_obj); + register_native_comp_unit (comp_u_lisp_obj); } if (!loading_dump) @@ -4701,7 +4696,7 @@ syms_of_comp (void) #ifdef WINDOWSNT staticpro (&all_loaded_comp_units_h); - all_loaded_comp_units_h = CALLN(Fmake_hash_table, QCweakness, Qvalue); + all_loaded_comp_units_h = CALLN (Fmake_hash_table, QCweakness, Qvalue); #endif DEFVAR_LISP ("comp-ctxt", Vcomp_ctxt, diff --git a/src/comp.h b/src/comp.h index 18c5ba1229..c6f23dc146 100644 --- a/src/comp.h +++ b/src/comp.h @@ -57,9 +57,9 @@ struct Lisp_Native_Comp_Unit #ifdef WINDOWSNT /* We need to store a copy of the original file name in memory that is not subject to GC because the function to dispose native - compilation units is called by the GC. By that time the `file' + compilation units is called by the GC. By that time the `file' string may have been sweeped. */ - char * cfile; + char *cfile; #endif }; @@ -92,7 +92,8 @@ extern void syms_of_comp (void); extern void maybe_defer_native_compilation (Lisp_Object function_name, Lisp_Object definition); -extern void dispose_comp_unit (struct Lisp_Native_Comp_Unit * comp_unit, bool delay); +extern void dispose_comp_unit (struct Lisp_Native_Comp_Unit * comp_unit, + bool delay); extern void finish_delayed_disposal_of_comp_units (void); diff --git a/src/pdumper.c b/src/pdumper.c index 26480388d5..b40a29c02a 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -5313,7 +5313,7 @@ dump_do_dump_relocation (const uintptr_t dump_base, installation_state == LOCAL_BUILD ? XCDR (comp_u->file) : XCAR (comp_u->file)); #ifdef WINDOWSNT - comp_u->cfile = xlispstrdup(comp_u->file); + comp_u->cfile = xlispstrdup (comp_u->file); #endif comp_u->handle = dynlib_open (SSDATA (comp_u->file)); if (!comp_u->handle) commit 1bc558b77e648efa905076f793d28fc0f025ae50 Author: Andrea Corallo Date: Sun May 24 21:50:19 2020 +0100 Fix non Windows builds * src/emacs.c (Fkill_emacs): Given 'finish_delayed_disposal_of_comp_units', 'dispose_all_remaining_comp_units' and 'clean_package_user_dir_of_old_comp_units' are defined only with windows native-comp builds ifdef them. * src/comp.h (dispose_comp_unit): Fix missing parameter in declaration. diff --git a/src/comp.h b/src/comp.h index b8e40ceb90..18c5ba1229 100644 --- a/src/comp.h +++ b/src/comp.h @@ -109,7 +109,7 @@ maybe_defer_native_compilation (Lisp_Object function_name, extern void syms_of_comp (void); static inline void -dispose_comp_unit (struct Lisp_Native_Comp_Unit * comp_handle) +dispose_comp_unit (struct Lisp_Native_Comp_Unit * comp_handle, bool delay) { eassert (false); } diff --git a/src/emacs.c b/src/emacs.c index 2a7a5257f1..cd4f7a0b28 100644 --- a/src/emacs.c +++ b/src/emacs.c @@ -2398,9 +2398,11 @@ all of which are called before Emacs is actually killed. */ unlink (SSDATA (listfile)); } +#if defined (HAVE_NATIVE_COMP) && defined (WINDOWSNT) finish_delayed_disposal_of_comp_units (); dispose_all_remaining_comp_units (); clean_package_user_dir_of_old_comp_units (); +#endif if (FIXNUMP (arg)) exit_code = (XFIXNUM (arg) < 0 commit 1b809f378f6263bc099da45c5e4a42c89fef8d71 Author: Nicolás Bértolo Date: Tue May 19 15:57:31 2020 -0300 Improve handling of native compilation units still in use in Windows When closing emacs will inspect all directories from which it loaded native compilation units. If it finds a ".eln.old" file it will try to delete it, if it fails that means that another Emacs instance is using it. When compiling a file we rename the file that was in the output path in case it has been loaded into another Emacs instance. When deleting a package we move any ".eln" or ".eln.old" files in the package folder that we can't delete to `package-user-dir`. Emacs will check that directory when closing and delete them. * lisp/emacs-lisp/comp.el (comp--replace-output-file): Function called from C code to finish the compilation process. It performs renaming of the old file if necessary. * lisp/emacs-lisp/package.el (package--delete-directory): Function to delete a package directory. It moves native compilation units that it can't delete to `package-user-dir'. * src/alloc.c (cleanup_vector): Call dispose_comp_unit(). (garbage_collect): Call finish_delayed_disposal_of_comp_units(). * src/comp.c: Restore the signal mask using unwind-protect. Store loaded native compilation units in a hash table for disposal on close. Store filenames of native compilation units GC'd in a linked list to finish their disposal when the GC is over. (clean_comp_unit_directory): Delete all *.eln.old files in a directory. (clean_package_user_dir_of_old_comp_units): Delete all *.eln.old files in `package-user-dir'. (dispose_all_remaining_comp_units): Dispose of native compilation units that are still loaded. (dispose_comp_unit): Close handle and cleanup directory or arrange for later cleanup if DELAY is true. (finish_delayed_disposal_of_comp_units): Dispose of native compilation units that were GC'd. (register_native_comp_unit): Register native compilation unit for disposal when Emacs closes. * src/comp.h: Introduce cfile member in Lisp_Native_Comp_Unit. Add declarations of functions that: clean directories of unused native compilation units, handle disposal of native compilation units. * src/emacs.c (kill-emacs): Dispose all remaining compilation units right right before calling exit(). * src/eval.c (internal_condition_case_3, internal_condition_case_4): Add functions. * src/lisp.h (internal_condition_case_3, internal_condition_case_4): Add functions. * src/pdumper.c (dump_do_dump_relocation): Set cfile to a copy of the Lisp string specifying the file path. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 6c152136fb..3845827f66 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2277,6 +2277,31 @@ Prepare every function for final compilation and drive the C back-end." ;; Some entry point support code. +(defun comp--replace-output-file (outfile tmpfile) + "Replace OUTFILE with TMPFILE taking the necessary steps when +dealing with shared libraries that may be loaded into Emacs" + (cond ((eq 'windows-nt system-type) + (ignore-errors (delete-file outfile)) + (let ((retry t)) + (while retry + (setf retry nil) + (condition-case _ + (progn + ;; outfile maybe recreated by another Emacs in + ;; between the following two rename-file calls + (if (file-exists-p outfile) + (rename-file outfile (make-temp-file-internal + (file-name-sans-extension outfile) + nil ".eln.old" nil) + t)) + (rename-file tmpfile outfile nil)) + (file-already-exists (setf retry t)))))) + ;; Remove the old eln instead of copying the new one into it + ;; to get a new inode and prevent crashes in case the old one + ;; is currently loaded. + (t (delete-file outfile) + (rename-file tmpfile outfile)))) + (defvar comp-files-queue () "List of Elisp files to be compiled.") diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index 808e4f34fc..4288d906ef 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -2204,6 +2204,35 @@ If some packages are not installed propose to install them." (equal (cadr (assq (package-desc-name pkg) package-alist)) pkg)) +(defun package--delete-directory (dir) + "Delete DIR recursively. +In Windows move .eln and .eln.old files that can not be deleted +to `package-user-dir'." + (cond ((eq 'windows-nt system-type) + (let ((retry t)) + (while retry + (setf retry nil) + (condition-case err + (delete-directory dir t) + (file-error + (cl-destructuring-bind (reason1 reason2 filename) err + (if (and (string= "Removing old name" reason1) + (string= "Permission denied" reason2) + (string-prefix-p (expand-file-name package-user-dir) + filename) + (or (string-suffix-p ".eln" filename) + (string-suffix-p ".eln.old" filename))) + (progn + (rename-file filename + (make-temp-file-internal + (concat package-user-dir + (file-name-base filename)) + nil ".eln.old" nil) + t) + (setf retry t)) + (signal (car err) (cdr err))))))))) + (t (delete-directory dir t)))) + (defun package-delete (pkg-desc &optional force nosave) "Delete package PKG-DESC. @@ -2256,7 +2285,7 @@ If NOSAVE is non-nil, the package is not removed from (package-desc-name pkg-used-elsewhere-by))) (t (add-hook 'post-command-hook #'package-menu--post-refresh) - (delete-directory dir t) + (package--delete-directory dir) ;; Remove NAME-VERSION.signed and NAME-readme.txt files. ;; ;; NAME-readme.txt files are no longer created, but they diff --git a/src/alloc.c b/src/alloc.c index 76d49d2efd..b892022125 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -3119,8 +3119,7 @@ cleanup_vector (struct Lisp_Vector *vector) { struct Lisp_Native_Comp_Unit *cu = PSEUDOVEC_STRUCT (vector, Lisp_Native_Comp_Unit); - eassert (cu->handle); - dynlib_close (cu->handle); + dispose_comp_unit (cu, true); } } diff --git a/src/comp.c b/src/comp.c index 68ad6d3eb8..16ad77c74b 100644 --- a/src/comp.c +++ b/src/comp.c @@ -411,6 +411,10 @@ load_gccjit_if_necessary (bool mandatory) #define CALL1I(fun, arg) \ CALLN (Ffuncall, intern_c_string (STR (fun)), arg) +/* Like call2 but stringify and intern. */ +#define CALL2I(fun, arg1, arg2) \ + CALLN (Ffuncall, intern_c_string (STR (fun)), arg1, arg2) + #define DECL_BLOCK(name, func) \ gcc_jit_block *(name) = \ gcc_jit_function_new_block ((func), STR (name)) @@ -435,6 +439,8 @@ typedef struct { ptrdiff_t size; } f_reloc_t; +sigset_t saved_sigset; + static f_reloc_t freloc; /* C side of the compiler context. */ @@ -3795,6 +3801,13 @@ DEFUN ("comp--release-ctxt", Fcomp__release_ctxt, Scomp__release_ctxt, return Qt; } +static void +restore_sigmask (void) +{ + pthread_sigmask (SIG_SETMASK, &saved_sigset, 0); + unblock_input (); +} + DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, Scomp__compile_ctxt_to_file, 1, 1, 0, @@ -3816,6 +3829,8 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, CALL1I (comp-data-container-idx, CALL1I (comp-ctxt-d-ephemeral, Vcomp_ctxt)); sigset_t oldset; + ptrdiff_t count = 0; + if (!noninteractive) { sigset_t blocked; @@ -3828,6 +3843,8 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, sigaddset (&blocked, SIGIO); #endif pthread_sigmask (SIG_BLOCK, &blocked, &oldset); + count = SPECPDL_INDEX (); + record_unwind_protect_void (restore_sigmask); } emit_ctxt_code (); @@ -3866,18 +3883,10 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, GCC_JIT_OUTPUT_KIND_DYNAMIC_LIBRARY, SSDATA (tmp_file)); - /* Remove the old eln instead of copying the new one into it to get - a new inode and prevent crashes in case the old one is currently - loaded. */ - if (!NILP (Ffile_exists_p (out_file))) - Fdelete_file (out_file, Qnil); - Frename_file (tmp_file, out_file, Qnil); + CALL2I(comp--replace-output-file, out_file, tmp_file); if (!noninteractive) - { - pthread_sigmask (SIG_SETMASK, &oldset, 0); - unblock_input (); - } + unbind_to (count, Qnil); return out_file; } @@ -3938,6 +3947,223 @@ helper_PSEUDOVECTOR_TYPEP_XUNTAG (Lisp_Object a, enum pvec_type code) code); } + +/*********************************/ +/* Disposal of compilation units */ +/*********************************/ + +/* +The problem: Windows does not let us delete an .eln file that has been +loaded by a process. This has two implications in Emacs: + +1) It is not possible to recompile a lisp file if the corresponding +.eln file has been loaded. This is because we'd like to use the same +filename, but we can't delete the old .eln file. + +2) It is not possible to delete a package using `package-delete' +if an .eln file has been loaded. + +* General idea + +The solution to these two problems is to move the foo.eln file +somewhere else and have the last Emacs instance using it delete it. +To make it easy to find what files need to be removed we use two approaches. + +In the 1) case we rename foo.eln to fooXXXXXX.eln.old in the same +folder. When Emacs is unloading "foo" (either GC'd the native +compilation unit or Emacs is closing (see below)) we delete all the +.eln.old files in the folder where the original foo.eln was stored. + +Ideally we'd figure out the new name of foo.eln and delete it if +it ends in .eln.old. There is no simple API to do this in +Windows. GetModuleFileName() returns the original filename, not the +current one. This forces us to put .eln.old files in an agreed upon +path. We cannot use %TEMP% because it may be in another drive and then +the rename operation would fail. + +In the 2) case we can't use the same folder where the .eln file +resided, as we are trying to completely remove the package. Since we +are removing packages we can safely move the .eln.old file to +`package-user-dir' as we are sure that that would not mean changing +drives. + +* Implementation details + +The concept of disposal of a native compilation unit refers to +unloading the shared library and deleting all the .eln.old files in +the directory. These are two separate steps. We'll call them +early-disposal and late-disposal. + +There are two data structures used: + +- The `all_loaded_comp_units_h` hashtable. + +This hashtable is used like an array of weak references to native +compilation units. This hash table is filled by load_comp_unit() and +dispose_all_remaining_comp_units() iterates over all values that were +not disposed by the GC and performs all disposal steps when Emacs is +closing. + +- The `delayed_comp_unit_disposal_list` list. + +This is were the dispose_comp_unit() function, when called by the GC +sweep stage, stores the original filenames of the disposed native +compilation units. This is an ad-hoc C structure instead of a Lisp +cons because we need to allocate instances of this structure during +the GC. + +The finish_delayed_disposal_of_comp_units() function will iterate over +this list and perform the late-disposal step when Emacs is closing. + +*/ + +#ifdef WINDOWSNT +#define OLD_ELN_SUFFIX_REGEXP build_string ("\\.eln\\.old\\'") + +static Lisp_Object all_loaded_comp_units_h; + +/* We need to allocate instances of this struct during a GC + * sweep. This is why it can't be transformed into a simple cons. + */ +struct delayed_comp_unit_disposal +{ + struct delayed_comp_unit_disposal *next; + char *filename; +}; + +struct delayed_comp_unit_disposal *delayed_comp_unit_disposal_list; + +static Lisp_Object +return_nil (Lisp_Object arg) +{ + return Qnil; +} + +/* Tries to remove all *.eln.old files in DIRNAME. + + * Any error is ignored because it may be due to the file being loaded + * in another Emacs instance. + */ +static void +clean_comp_unit_directory (Lisp_Object dirpath) +{ + if (NILP (dirpath)) + return; + Lisp_Object files_in_dir; + files_in_dir = internal_condition_case_4 (Fdirectory_files, dirpath, Qt, + OLD_ELN_SUFFIX_REGEXP, Qnil, Qt, + return_nil); + FOR_EACH_TAIL (files_in_dir) { DeleteFile (SSDATA (XCAR (files_in_dir))); } +} + +/* Tries to remove all *.eln.old files in `package-user-dir'. + + * This is called when Emacs is closing to clean any *.eln left from a + * deleted package. + */ +void +clean_package_user_dir_of_old_comp_units (void) +{ + Lisp_Object package_user_dir + = find_symbol_value (intern ("package-user-dir")); + if (EQ (package_user_dir, Qunbound) || !STRINGP (package_user_dir)) + return; + + clean_comp_unit_directory (package_user_dir); +} + +/* This function disposes all compilation units that are still loaded. + * It is important that this function is called only right before + * Emacs is closed, otherwise we risk running a subr that is + * implemented in an unloaded dynamic library. + */ +void +dispose_all_remaining_comp_units (void) +{ + struct Lisp_Hash_Table *h = XHASH_TABLE (all_loaded_comp_units_h); + + for (ptrdiff_t i = 0; i < HASH_TABLE_SIZE (h); ++i) + { + Lisp_Object k = HASH_KEY (h, i); + if (!EQ (k, Qunbound)) + { + Lisp_Object val = HASH_VALUE (h, i); + struct Lisp_Native_Comp_Unit *cu = XNATIVE_COMP_UNIT (val); + dispose_comp_unit (cu, false); + } + } +} + +/* This function finishes the disposal of compilation units that were + * passed to `dispose_comp_unit` with DELAY == true. + * + * This function is called when Emacs is idle and when it is about to + * close. + */ +void +finish_delayed_disposal_of_comp_units (void) +{ + for (struct delayed_comp_unit_disposal *item + = delayed_comp_unit_disposal_list; + delayed_comp_unit_disposal_list; item = delayed_comp_unit_disposal_list) + { + delayed_comp_unit_disposal_list = item->next; + Lisp_Object dirname = internal_condition_case_1 ( + Ffile_name_directory, build_string (item->filename), Qt, return_nil); + clean_comp_unit_directory (dirname); + xfree (item->filename); + xfree (item); + } +} +#endif + +/* This function puts the compilation unit in the + * `all_loaded_comp_units_h` hashmap. + */ +static void +register_native_comp_unit (Lisp_Object comp_u) +{ +#ifdef WINDOWSNT + Fputhash (CALL1I (gensym, Qnil), comp_u, all_loaded_comp_units_h); +#endif +} + +/* This function disposes compilation units. It is called during the GC sweep + * stage and when Emacs is closing. + + * On Windows the the DELAY parameter specifies whether the native + * compilation file will be deleted right away (if necessary) or put + * on a list. That list will be dealt with by + * `finish_delayed_disposal_of_comp_units`. + */ +void +dispose_comp_unit (struct Lisp_Native_Comp_Unit *comp_handle, bool delay) +{ + eassert (comp_handle->handle); + dynlib_close (comp_handle->handle); +#ifdef WINDOWSNT + if (!delay) + { + Lisp_Object dirname = internal_condition_case_1 ( + Ffile_name_directory, build_string (comp_handle->cfile), Qt, + return_nil); + if (!NILP (dirname)) + clean_comp_unit_directory (dirname); + xfree (comp_handle->cfile); + comp_handle->cfile = NULL; + } + else + { + struct delayed_comp_unit_disposal *head; + head = xmalloc (sizeof (struct delayed_comp_unit_disposal)); + head->next = delayed_comp_unit_disposal_list; + head->filename = comp_handle->cfile; + comp_handle->cfile = NULL; + delayed_comp_unit_disposal_list = head; + } +#endif +} + /***********************************/ /* Deferred compilation mechanism. */ @@ -4159,6 +4385,12 @@ load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u, bool loading_dump, d_vec_len = XFIXNUM (Flength (comp_u->data_impure_vec)); for (EMACS_INT i = 0; i < d_vec_len; i++) data_imp_relocs[i] = AREF (comp_u->data_impure_vec, i); + + /* If we register them while dumping we will get some entries in + the hash table that will be duplicated when pdumper calls + load_comp_unit. */ + if (!will_dump_p ()) + register_native_comp_unit (comp_u_lisp_obj); } if (!loading_dump) @@ -4316,6 +4548,9 @@ DEFUN ("native-elisp-load", Fnative_elisp_load, Snative_elisp_load, 1, 2, 0, if (!comp_u->handle) xsignal2 (Qnative_lisp_load_failed, file, build_string (dynlib_error ())); comp_u->file = file; +#ifdef WINDOWSNT + comp_u->cfile = xlispstrdup (file); +#endif comp_u->data_vec = Qnil; comp_u->lambda_gc_guard = CALLN (Fmake_hash_table, QCtest, Qeq); comp_u->lambda_c_name_idx_h = CALLN (Fmake_hash_table, QCtest, Qequal); @@ -4464,6 +4699,11 @@ syms_of_comp (void) staticpro (&delayed_sources); delayed_sources = Qnil; +#ifdef WINDOWSNT + staticpro (&all_loaded_comp_units_h); + all_loaded_comp_units_h = CALLN(Fmake_hash_table, QCweakness, Qvalue); +#endif + DEFVAR_LISP ("comp-ctxt", Vcomp_ctxt, doc: /* The compiler context. */); Vcomp_ctxt = Qnil; diff --git a/src/comp.h b/src/comp.h index 36e7cdf441..b8e40ceb90 100644 --- a/src/comp.h +++ b/src/comp.h @@ -52,7 +52,15 @@ struct Lisp_Native_Comp_Unit /* STUFFS WE DO NOT DUMP!! */ Lisp_Object *data_imp_relocs; bool loaded_once; + dynlib_handle_ptr handle; +#ifdef WINDOWSNT + /* We need to store a copy of the original file name in memory that + is not subject to GC because the function to dispose native + compilation units is called by the GC. By that time the `file' + string may have been sweeped. */ + char * cfile; +#endif }; #ifdef HAVE_NATIVE_COMP @@ -83,6 +91,14 @@ extern void syms_of_comp (void); extern void maybe_defer_native_compilation (Lisp_Object function_name, Lisp_Object definition); + +extern void dispose_comp_unit (struct Lisp_Native_Comp_Unit * comp_unit, bool delay); + +extern void finish_delayed_disposal_of_comp_units (void); + +extern void dispose_all_remaining_comp_units (void); + +extern void clean_package_user_dir_of_old_comp_units (void); #else static inline void @@ -92,6 +108,24 @@ maybe_defer_native_compilation (Lisp_Object function_name, extern void syms_of_comp (void); +static inline void +dispose_comp_unit (struct Lisp_Native_Comp_Unit * comp_handle) +{ + eassert (false); +} + +static inline void +dispose_all_remaining_comp_units (void) +{} + +static inline void +clean_package_user_dir_of_old_comp_units (void) +{} + +static inline void +finish_delayed_disposal_of_comp_units (void) +{} + #endif #endif diff --git a/src/emacs.c b/src/emacs.c index 93a837a44e..2a7a5257f1 100644 --- a/src/emacs.c +++ b/src/emacs.c @@ -2398,6 +2398,10 @@ all of which are called before Emacs is actually killed. */ unlink (SSDATA (listfile)); } + finish_delayed_disposal_of_comp_units (); + dispose_all_remaining_comp_units (); + clean_package_user_dir_of_old_comp_units (); + if (FIXNUMP (arg)) exit_code = (XFIXNUM (arg) < 0 ? XFIXNUM (arg) | INT_MIN diff --git a/src/eval.c b/src/eval.c index 37d466f69e..9e86a18590 100644 --- a/src/eval.c +++ b/src/eval.c @@ -1419,6 +1419,61 @@ internal_condition_case_2 (Lisp_Object (*bfun) (Lisp_Object, Lisp_Object), } } +/* Like internal_condition_case_1 but call BFUN with ARG1, ARG2, ARG3 as + its arguments. */ + +Lisp_Object +internal_condition_case_3 (Lisp_Object (*bfun) (Lisp_Object, Lisp_Object, + Lisp_Object), + Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3, + Lisp_Object handlers, + Lisp_Object (*hfun) (Lisp_Object)) +{ + struct handler *c = push_handler (handlers, CONDITION_CASE); + if (sys_setjmp (c->jmp)) + { + Lisp_Object val = handlerlist->val; + clobbered_eassert (handlerlist == c); + handlerlist = handlerlist->next; + return hfun (val); + } + else + { + Lisp_Object val = bfun (arg1, arg2, arg3); + eassert (handlerlist == c); + handlerlist = c->next; + return val; + } +} + +/* Like internal_condition_case_1 but call BFUN with ARG1, ARG2, ARG3, ARG4 as + its arguments. */ + +Lisp_Object +internal_condition_case_4 (Lisp_Object (*bfun) (Lisp_Object, Lisp_Object, + Lisp_Object, Lisp_Object), + Lisp_Object arg1, Lisp_Object arg2, + Lisp_Object arg3, Lisp_Object arg4, + Lisp_Object handlers, + Lisp_Object (*hfun) (Lisp_Object)) +{ + struct handler *c = push_handler (handlers, CONDITION_CASE); + if (sys_setjmp (c->jmp)) + { + Lisp_Object val = handlerlist->val; + clobbered_eassert (handlerlist == c); + handlerlist = handlerlist->next; + return hfun (val); + } + else + { + Lisp_Object val = bfun (arg1, arg2, arg3, arg4); + eassert (handlerlist == c); + handlerlist = c->next; + return val; + } +} + /* Like internal_condition_case but call BFUN with NARGS as first, and ARGS as second argument. */ diff --git a/src/lisp.h b/src/lisp.h index 4c0057b255..52242791aa 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -4165,6 +4165,8 @@ extern Lisp_Object internal_lisp_condition_case (Lisp_Object, Lisp_Object, Lisp_ extern Lisp_Object internal_condition_case (Lisp_Object (*) (void), Lisp_Object, Lisp_Object (*) (Lisp_Object)); extern Lisp_Object internal_condition_case_1 (Lisp_Object (*) (Lisp_Object), Lisp_Object, Lisp_Object, Lisp_Object (*) (Lisp_Object)); extern Lisp_Object internal_condition_case_2 (Lisp_Object (*) (Lisp_Object, Lisp_Object), Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object (*) (Lisp_Object)); +extern Lisp_Object internal_condition_case_3 (Lisp_Object (*) (Lisp_Object, Lisp_Object, Lisp_Object), Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object (*) (Lisp_Object)); +extern Lisp_Object internal_condition_case_4 (Lisp_Object (*) (Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object), Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object (*) (Lisp_Object)); extern Lisp_Object internal_condition_case_n (Lisp_Object (*) (ptrdiff_t, Lisp_Object *), ptrdiff_t, Lisp_Object *, Lisp_Object, Lisp_Object (*) (Lisp_Object, ptrdiff_t, Lisp_Object *)); diff --git a/src/pdumper.c b/src/pdumper.c index a6d12b6ea0..26480388d5 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -5312,6 +5312,9 @@ dump_do_dump_relocation (const uintptr_t dump_base, concat2 (Vinvocation_directory, installation_state == LOCAL_BUILD ? XCDR (comp_u->file) : XCAR (comp_u->file)); +#ifdef WINDOWSNT + comp_u->cfile = xlispstrdup(comp_u->file); +#endif comp_u->handle = dynlib_open (SSDATA (comp_u->file)); if (!comp_u->handle) error ("%s", dynlib_error ()); commit 9daffe9cfe82d3b1e1e9fa8929dbb40cfed60f0f Merge: f5dceed09a e021c2dc22 Author: Andrea Corallo Date: Sun May 24 10:20:23 2020 +0100 Merge remote-tracking branch 'savannah/master' into HEAD commit f5dceed09a8234548d5b3acb76d443569533cab9 Author: Andrea Corallo Date: Sat May 23 14:25:44 2020 +0100 * lisp/loadup.el: Use new 'native-comp-available-p'. diff --git a/lisp/loadup.el b/lisp/loadup.el index 7cf2cb01c3..31843fc24d 100644 --- a/lisp/loadup.el +++ b/lisp/loadup.el @@ -449,7 +449,7 @@ lost after dumping"))) ;; At this point, we're ready to resume undo recording for scratch. (buffer-enable-undo "*scratch*") -(when (boundp 'comp-ctxt) ; FIXME better native-comp feature discriminant? +(when (native-comp-available-p) ;; Fix the compilation unit filename to have it working when ;; when installed or if the source directory got moved. This is set to be ;; a pair in the form: (rel-path-from-install-bin . rel-path-from-local-bin). commit d59607b68592fa709bd8466a3ac7300d280df83a Author: Nicolás Bértolo Date: Wed May 13 16:22:17 2020 -0300 * Windows: Use NUMBER_OF_PROCESSORS environment variable. * lisp/emacs-lisp/comp.el (comp-effective-async-max-jobs): Use NUMBER_OF_PROCESSORS environment variable if system is Windows NT, "nproc" if it is in PATH or a default of 1. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index e5d3be6eed..6c152136fb 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2302,9 +2302,14 @@ processes from `comp-async-compilations'" (if (zerop comp-async-jobs-number) (or comp-num-cpus (setf comp-num-cpus - ;; Half of the CPUs or at least one. - ;; FIXME portable? - (max 1 (/ (string-to-number (shell-command-to-string "nproc")) + ;; FIXME: we already have a function to determine + ;; the number of processors, see get_native_system_info in w32.c. + ;; The result needs to be exported to Lisp. + (max 1 (/ (cond ((eq 'windows-nt system-type) + (string-to-number (getenv "NUMBER_OF_PROCESSORS"))) + ((executable-find "nproc") + (string-to-number (shell-command-to-string "nproc"))) + (t 1)) 2)))) comp-async-jobs-number)) commit 60b326ef112b6196cccf8bf9508df9e6622285cb Author: Nicolás Bértolo Date: Fri May 8 14:04:06 2020 -0300 * Workaround the 32768 chars command line limit in Windows. * lisp/emacs-lisp/comp.el (comp-run-async-workers): Pass the compilation commands through a temporary file that is loaded by the child process. This is also done all other operating systems, even those that support long command lines. It should not be a problem since libgccjit uses temporary files too. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 9fe614f9e9..e5d3be6eed 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2337,6 +2337,10 @@ display a message." (_ (progn (comp-log "\n") (comp-log (prin1-to-string expr)))) + (temp-file (make-temp-file + (concat "emacs-async-comp-" + (file-name-base source-file) "-") + nil ".el" (prin1-to-string expr))) (load1 load) (process (make-process :name (concat "Compiling: " source-file) @@ -2344,13 +2348,14 @@ display a message." :command (list (expand-file-name invocation-name invocation-directory) - "--batch" "--eval" (prin1-to-string expr)) + "--batch" "-l" temp-file) :sentinel (lambda (process _event) (run-hook-with-args 'comp-async-cu-done-hook source-file) (accept-process-output process) + (ignore-errors (delete-file temp-file)) (when (and load1 (zerop (process-exit-status process))) (native-elisp-load commit 21aef26a4c0234c3af6e3fdd269292a726aa0f48 Author: Andrea Corallo Date: Sat May 23 08:45:51 2020 +0100 * src/comp.c: Aesthetic, GNU style fixes. diff --git a/src/comp.c b/src/comp.c index d72fa92746..68ad6d3eb8 100644 --- a/src/comp.c +++ b/src/comp.c @@ -232,66 +232,64 @@ DEF_DLL_FN (void, gcc_jit_struct_set_fields, static bool init_gccjit_functions (void) { - HMODULE library; + HMODULE library = w32_delayed_load (Qgccjit); - if (!(library = w32_delayed_load (Qgccjit))) - { - return false; - } + if (!library) + return false; /* In alphabetical order */ - LOAD_DLL_FN(library, gcc_jit_block_add_assignment); - LOAD_DLL_FN(library, gcc_jit_block_add_comment); - LOAD_DLL_FN(library, gcc_jit_block_add_eval); - LOAD_DLL_FN(library, gcc_jit_block_end_with_conditional); - LOAD_DLL_FN(library, gcc_jit_block_end_with_jump); - LOAD_DLL_FN(library, gcc_jit_block_end_with_return); - LOAD_DLL_FN(library, gcc_jit_block_end_with_void_return); - LOAD_DLL_FN(library, gcc_jit_context_acquire); - LOAD_DLL_FN(library, gcc_jit_context_compile_to_file); - LOAD_DLL_FN(library, gcc_jit_context_dump_reproducer_to_file); - LOAD_DLL_FN(library, gcc_jit_context_dump_to_file); - LOAD_DLL_FN(library, gcc_jit_context_get_builtin_function); - LOAD_DLL_FN(library, gcc_jit_context_get_first_error); - LOAD_DLL_FN(library, gcc_jit_context_get_int_type); - LOAD_DLL_FN(library, gcc_jit_context_get_type); - LOAD_DLL_FN(library, gcc_jit_context_new_array_access); - LOAD_DLL_FN(library, gcc_jit_context_new_array_type); - LOAD_DLL_FN(library, gcc_jit_context_new_binary_op); - LOAD_DLL_FN(library, gcc_jit_context_new_call); - LOAD_DLL_FN(library, gcc_jit_context_new_call_through_ptr); - LOAD_DLL_FN(library, gcc_jit_context_new_comparison); - LOAD_DLL_FN(library, gcc_jit_context_new_field); - LOAD_DLL_FN(library, gcc_jit_context_new_function); - LOAD_DLL_FN(library, gcc_jit_context_new_function_ptr_type); - LOAD_DLL_FN(library, gcc_jit_context_new_global); - LOAD_DLL_FN(library, gcc_jit_context_new_opaque_struct); - LOAD_DLL_FN(library, gcc_jit_context_new_param); - LOAD_DLL_FN(library, gcc_jit_context_new_rvalue_from_int); - LOAD_DLL_FN(library, gcc_jit_context_new_rvalue_from_long); - LOAD_DLL_FN(library, gcc_jit_context_new_rvalue_from_ptr); - LOAD_DLL_FN(library, gcc_jit_context_new_struct_type); - LOAD_DLL_FN(library, gcc_jit_context_new_unary_op); - LOAD_DLL_FN(library, gcc_jit_context_new_union_type); - LOAD_DLL_FN(library, gcc_jit_context_release); - LOAD_DLL_FN(library, gcc_jit_context_set_bool_option); - LOAD_DLL_FN(library, gcc_jit_context_set_int_option); - LOAD_DLL_FN(library, gcc_jit_context_set_logfile); - LOAD_DLL_FN(library, gcc_jit_function_get_param); - LOAD_DLL_FN(library, gcc_jit_function_new_block); - LOAD_DLL_FN(library, gcc_jit_function_new_local); - LOAD_DLL_FN(library, gcc_jit_lvalue_access_field); - LOAD_DLL_FN(library, gcc_jit_lvalue_as_rvalue); - LOAD_DLL_FN(library, gcc_jit_lvalue_get_address); - LOAD_DLL_FN(library, gcc_jit_param_as_lvalue); - LOAD_DLL_FN(library, gcc_jit_param_as_rvalue); - LOAD_DLL_FN(library, gcc_jit_rvalue_access_field); - LOAD_DLL_FN(library, gcc_jit_rvalue_dereference); - LOAD_DLL_FN(library, gcc_jit_rvalue_dereference_field); - LOAD_DLL_FN(library, gcc_jit_rvalue_get_type); - LOAD_DLL_FN(library, gcc_jit_struct_as_type); - LOAD_DLL_FN(library, gcc_jit_struct_set_fields); - LOAD_DLL_FN(library, gcc_jit_type_get_pointer); + LOAD_DLL_FN (library, gcc_jit_block_add_assignment); + LOAD_DLL_FN (library, gcc_jit_block_add_comment); + LOAD_DLL_FN (library, gcc_jit_block_add_eval); + LOAD_DLL_FN (library, gcc_jit_block_end_with_conditional); + LOAD_DLL_FN (library, gcc_jit_block_end_with_jump); + LOAD_DLL_FN (library, gcc_jit_block_end_with_return); + LOAD_DLL_FN (library, gcc_jit_block_end_with_void_return); + LOAD_DLL_FN (library, gcc_jit_context_acquire); + LOAD_DLL_FN (library, gcc_jit_context_compile_to_file); + LOAD_DLL_FN (library, gcc_jit_context_dump_reproducer_to_file); + LOAD_DLL_FN (library, gcc_jit_context_dump_to_file); + LOAD_DLL_FN (library, gcc_jit_context_get_builtin_function); + LOAD_DLL_FN (library, gcc_jit_context_get_first_error); + LOAD_DLL_FN (library, gcc_jit_context_get_int_type); + LOAD_DLL_FN (library, gcc_jit_context_get_type); + LOAD_DLL_FN (library, gcc_jit_context_new_array_access); + LOAD_DLL_FN (library, gcc_jit_context_new_array_type); + LOAD_DLL_FN (library, gcc_jit_context_new_binary_op); + LOAD_DLL_FN (library, gcc_jit_context_new_call); + LOAD_DLL_FN (library, gcc_jit_context_new_call_through_ptr); + LOAD_DLL_FN (library, gcc_jit_context_new_comparison); + LOAD_DLL_FN (library, gcc_jit_context_new_field); + LOAD_DLL_FN (library, gcc_jit_context_new_function); + LOAD_DLL_FN (library, gcc_jit_context_new_function_ptr_type); + LOAD_DLL_FN (library, gcc_jit_context_new_global); + LOAD_DLL_FN (library, gcc_jit_context_new_opaque_struct); + LOAD_DLL_FN (library, gcc_jit_context_new_param); + LOAD_DLL_FN (library, gcc_jit_context_new_rvalue_from_int); + LOAD_DLL_FN (library, gcc_jit_context_new_rvalue_from_long); + LOAD_DLL_FN (library, gcc_jit_context_new_rvalue_from_ptr); + LOAD_DLL_FN (library, gcc_jit_context_new_struct_type); + LOAD_DLL_FN (library, gcc_jit_context_new_unary_op); + LOAD_DLL_FN (library, gcc_jit_context_new_union_type); + LOAD_DLL_FN (library, gcc_jit_context_release); + LOAD_DLL_FN (library, gcc_jit_context_set_bool_option); + LOAD_DLL_FN (library, gcc_jit_context_set_int_option); + LOAD_DLL_FN (library, gcc_jit_context_set_logfile); + LOAD_DLL_FN (library, gcc_jit_function_get_param); + LOAD_DLL_FN (library, gcc_jit_function_new_block); + LOAD_DLL_FN (library, gcc_jit_function_new_local); + LOAD_DLL_FN (library, gcc_jit_lvalue_access_field); + LOAD_DLL_FN (library, gcc_jit_lvalue_as_rvalue); + LOAD_DLL_FN (library, gcc_jit_lvalue_get_address); + LOAD_DLL_FN (library, gcc_jit_param_as_lvalue); + LOAD_DLL_FN (library, gcc_jit_param_as_rvalue); + LOAD_DLL_FN (library, gcc_jit_rvalue_access_field); + LOAD_DLL_FN (library, gcc_jit_rvalue_dereference); + LOAD_DLL_FN (library, gcc_jit_rvalue_dereference_field); + LOAD_DLL_FN (library, gcc_jit_rvalue_get_type); + LOAD_DLL_FN (library, gcc_jit_struct_as_type); + LOAD_DLL_FN (library, gcc_jit_struct_set_fields); + LOAD_DLL_FN (library, gcc_jit_type_get_pointer); return true; } @@ -369,7 +367,7 @@ load_gccjit_if_necessary (bool mandatory) } if (mandatory && !gccjit_initialized) - xsignal1(Qnative_compiler_error, build_string("libgccjit not found")); + xsignal1 (Qnative_compiler_error, build_string ("libgccjit not found")); return gccjit_initialized; #else @@ -1242,7 +1240,7 @@ emit_XUNTAG (gcc_jit_rvalue *a, gcc_jit_type *type, Lisp_Word_tag lisp_word_tag) GCC_JIT_BINARY_OP_MINUS, comp.uintptr_type, emit_XLP (a), - emit_rvalue_from_lisp_word_tag(lisp_word_tag))); + emit_rvalue_from_lisp_word_tag (lisp_word_tag))); } static gcc_jit_rvalue * @@ -3637,7 +3635,7 @@ DEFUN ("comp--init-ctxt", Fcomp__init_ctxt, Scomp__init_ctxt, doc: /* Initialize the native compiler context. Return t on success. */) (void) { - load_gccjit_if_necessary(true); + load_gccjit_if_necessary (true); if (comp.ctxt) { @@ -3785,7 +3783,7 @@ DEFUN ("comp--release-ctxt", Fcomp__release_ctxt, Scomp__release_ctxt, doc: /* Release the native compiler context. */) (void) { - load_gccjit_if_necessary(true); + load_gccjit_if_necessary (true); if (comp.ctxt) gcc_jit_context_release (comp.ctxt); @@ -3803,7 +3801,7 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, doc: /* Compile as native code the current context to file. */) (Lisp_Object base_name) { - load_gccjit_if_necessary(true); + load_gccjit_if_necessary (true); CHECK_STRING (base_name); @@ -3963,7 +3961,7 @@ maybe_defer_native_compilation (Lisp_Object function_name, if (!f) { char str[128]; - sprintf (str, "log_%d", getpid()); + sprintf (str, "log_%d", getpid ()); f = fopen (str, "w"); } if (!f) @@ -3974,7 +3972,7 @@ maybe_defer_native_compilation (Lisp_Object function_name, fflush (f); } #endif - if (!load_gccjit_if_necessary(false)) + if (!load_gccjit_if_necessary (false)) return; if (!comp_deferred_compilation @@ -4313,7 +4311,7 @@ DEFUN ("native-elisp-load", Fnative_elisp_load, Snative_elisp_load, 1, 2, 0, if (NILP (Ffile_exists_p (file))) xsignal2 (Qnative_lisp_load_failed, build_string ("file does not exists"), file); - struct Lisp_Native_Comp_Unit *comp_u = allocate_native_comp_unit(); + struct Lisp_Native_Comp_Unit *comp_u = allocate_native_comp_unit (); comp_u->handle = dynlib_open (SSDATA (file)); if (!comp_u->handle) xsignal2 (Qnative_lisp_load_failed, file, build_string (dynlib_error ())); @@ -4335,7 +4333,7 @@ this instance of Emacs. */) (void) { #ifdef HAVE_NATIVE_COMP - return load_gccjit_if_necessary(false) ? Qt : Qnil; + return load_gccjit_if_necessary (false) ? Qt : Qnil; #else return Qnil; #endif commit 483cdf7a7942c91f6691953c9fe4618194dd175b Author: Nicolás Bértolo Date: Mon May 11 20:43:06 2020 -0300 Load libgccjit dynamically in Windows. * configure.ac: don't add linker flags if compiling on Windows. Compile dynlib.c if modules or native compilation are enabled. Always compile comp.c * lisp/term/w32-win.el: Map 'gccjit to "libgccjit.dll" in `dynamic-library-alist`. * src/Makefile.in: Update comments. Update to handle changes in configure.ac. * src/comp.c: Add declarations of used libgccjit functions using DEF_DLL_FN. Add calls to load_gccjit_if_necessary() where necessary. Add `native-comp-available-p` * src/comp.h: Remove Fnative_elisp_load. Add syms_of_comp(). * src/emacs.c (main): Always call syms_of_comp() * src/w32.c (globals_of_w32): Clear Vlibrary_cache when starting because the libraries loaded when dumping will not be loaded when starting. * src/w32fns.c: Add Qgccjit symbol. diff --git a/configure.ac b/configure.ac index 23b94cf6ca..ea0144f404 100644 --- a/configure.ac +++ b/configure.ac @@ -3666,6 +3666,7 @@ AC_SUBST(LIBZ) LIBMODULES= HAVE_MODULES=no MODULES_OBJ= +NEED_DYNLIB=no case $opsys in cygwin|mingw32) MODULES_SUFFIX=".dll" ;; darwin) MODULES_SUFFIX=".dylib" ;; @@ -3701,7 +3702,8 @@ if test "${with_modules}" != "no"; then fi if test "${HAVE_MODULES}" = yes; then - MODULES_OBJ="dynlib.o emacs-module.o" + MODULES_OBJ="emacs-module.o" + NEED_DYNLIB=yes AC_DEFINE(HAVE_MODULES, 1, [Define to 1 if dynamic modules are enabled]) AC_DEFINE_UNQUOTED(MODULES_SUFFIX, "$MODULES_SUFFIX", [System extension for dynamic libraries]) @@ -3785,7 +3787,6 @@ Here instructions on how to compile and install libgccjit from source: HAVE_NATIVE_COMP=no LIBGCCJIT_LIB= -COMP_OBJ= if test "${with_nativecomp}" != "no"; then emacs_save_LIBS=$LIBS LIBS="-lgccjit" @@ -3793,8 +3794,11 @@ if test "${with_nativecomp}" != "no"; then [AC_LINK_IFELSE([libgccjit_smoke_test], [], [libgccjit_not_found])]) LIBS=$emacs_save_LIBS HAVE_NATIVE_COMP=yes - LIBGCCJIT_LIB="-lgccjit -ldl" - COMP_OBJ="comp.o" + # mingw32 loads the library dynamically. + if test "${opsys}" != "mingw32"; then + LIBGCCJIT_LIB="-lgccjit -ldl" + fi + NEED_DYNLIB=yes AC_DEFINE(HAVE_NATIVE_COMP, 1, [Define to 1 if you have the libgccjit library (-lgccjit).]) fi if test "${HAVE_NATIVE_COMP}" = yes && test "${HAVE_PDUMPER}" = no; then @@ -3804,7 +3808,12 @@ AC_DEFINE_UNQUOTED(NATIVE_ELISP_SUFFIX, ".eln", [System extension for native compiled elisp]) AC_SUBST(HAVE_NATIVE_COMP) AC_SUBST(LIBGCCJIT_LIB) -AC_SUBST(COMP_OBJ) + +DYNLIB_OBJ= +if test "${NEED_DYNLIB}" = yes; then + DYNLIB_OBJ="dynlib.o" +fi +AC_SUBST(DYNLIB_OBJ) ### Use -lpng if available, unless '--with-png=no'. HAVE_PNG=no diff --git a/lisp/term/w32-win.el b/lisp/term/w32-win.el index 5901e0295e..6b9716ca30 100644 --- a/lisp/term/w32-win.el +++ b/lisp/term/w32-win.el @@ -289,7 +289,8 @@ See the documentation of `create-fontset-from-fontset-spec' for the format.") '(libxml2 "libxml2-2.dll" "libxml2.dll") '(zlib "zlib1.dll" "libz-1.dll") '(lcms2 "liblcms2-2.dll") - '(json "libjansson-4.dll"))) + '(json "libjansson-4.dll") + '(gccjit "libgccjit.dll"))) ;;; multi-tty support (defvar w32-initialized nil diff --git a/src/Makefile.in b/src/Makefile.in index 63f909ae14..85709184da 100644 --- a/src/Makefile.in +++ b/src/Makefile.in @@ -241,7 +241,7 @@ LIBZ = @LIBZ@ ## system-specific libs for dynamic modules, else empty LIBMODULES = @LIBMODULES@ -## dynlib.o emacs-module.o if modules enabled, else empty +## emacs-module.o if modules enabled, else empty MODULES_OBJ = @MODULES_OBJ@ XRANDR_LIBS = @XRANDR_LIBS@ @@ -327,8 +327,9 @@ GMP_LIB = @GMP_LIB@ GMP_OBJ = @GMP_OBJ@ LIBGCCJIT = @LIBGCCJIT_LIB@ -## dynlib.o comp.o if native compiler is enabled, otherwise empty. -COMP_OBJ = @COMP_OBJ@ + +## dynlib.o if necessary, else empty +DYNLIB_OBJ = @DYNLIB_OBJ@ RUN_TEMACS = ./temacs @@ -418,7 +419,7 @@ base_obj = dispnew.o frame.o scroll.o xdisp.o menu.o $(XMENU_OBJ) window.o \ cmds.o casetab.o casefiddle.o indent.o search.o regex-emacs.o undo.o \ alloc.o pdumper.o data.o doc.o editfns.o callint.o \ eval.o floatfns.o fns.o font.o print.o lread.o $(MODULES_OBJ) \ - syntax.o $(UNEXEC_OBJ) bytecode.o $(COMP_OBJ) \ + syntax.o $(UNEXEC_OBJ) bytecode.o comp.o $(DYNLIB_OBJ) \ process.o gnutls.o callproc.o \ region-cache.o sound.o timefns.o atimer.o \ doprnt.o intervals.o textprop.o composite.o xml.o lcms.o $(NOTIFY_OBJ) \ diff --git a/src/comp.c b/src/comp.c index 994bd7db93..d72fa92746 100644 --- a/src/comp.c +++ b/src/comp.c @@ -20,6 +20,8 @@ along with GNU Emacs. If not, see . */ #include +#include "lisp.h" + #ifdef HAVE_NATIVE_COMP #include @@ -28,7 +30,6 @@ along with GNU Emacs. If not, see . */ #include #include -#include "lisp.h" #include "puresize.h" #include "window.h" #include "dynlib.h" @@ -36,6 +37,347 @@ along with GNU Emacs. If not, see . */ #include "blockinput.h" #include "sha512.h" + +/********************************/ +/* Dynamic loading of libgccjit */ +/********************************/ + +#ifdef WINDOWSNT +# include "w32common.h" + +#undef gcc_jit_block_add_assignment +#undef gcc_jit_block_add_comment +#undef gcc_jit_block_add_eval +#undef gcc_jit_block_end_with_conditional +#undef gcc_jit_block_end_with_jump +#undef gcc_jit_block_end_with_return +#undef gcc_jit_block_end_with_void_return +#undef gcc_jit_context_acquire +#undef gcc_jit_context_compile_to_file +#undef gcc_jit_context_dump_reproducer_to_file +#undef gcc_jit_context_dump_to_file +#undef gcc_jit_context_get_builtin_function +#undef gcc_jit_context_get_first_error +#undef gcc_jit_context_get_int_type +#undef gcc_jit_context_get_type +#undef gcc_jit_context_new_array_access +#undef gcc_jit_context_new_array_type +#undef gcc_jit_context_new_binary_op +#undef gcc_jit_context_new_call +#undef gcc_jit_context_new_call_through_ptr +#undef gcc_jit_context_new_comparison +#undef gcc_jit_context_new_field +#undef gcc_jit_context_new_function +#undef gcc_jit_context_new_function_ptr_type +#undef gcc_jit_context_new_global +#undef gcc_jit_context_new_opaque_struct +#undef gcc_jit_context_new_param +#undef gcc_jit_context_new_rvalue_from_int +#undef gcc_jit_context_new_rvalue_from_long +#undef gcc_jit_context_new_rvalue_from_ptr +#undef gcc_jit_context_new_struct_type +#undef gcc_jit_context_new_unary_op +#undef gcc_jit_context_new_union_type +#undef gcc_jit_context_release +#undef gcc_jit_context_set_bool_option +#undef gcc_jit_context_set_int_option +#undef gcc_jit_context_set_logfile +#undef gcc_jit_function_get_param +#undef gcc_jit_function_new_block +#undef gcc_jit_function_new_local +#undef gcc_jit_lvalue_access_field +#undef gcc_jit_lvalue_as_rvalue +#undef gcc_jit_lvalue_get_address +#undef gcc_jit_param_as_lvalue +#undef gcc_jit_param_as_rvalue +#undef gcc_jit_rvalue_access_field +#undef gcc_jit_rvalue_dereference +#undef gcc_jit_rvalue_dereference_field +#undef gcc_jit_rvalue_get_type +#undef gcc_jit_struct_as_type +#undef gcc_jit_struct_set_fields +#undef gcc_jit_type_get_pointer + +/* In alphabetical order */ +DEF_DLL_FN (gcc_jit_rvalue *, gcc_jit_context_new_rvalue_from_int, + (gcc_jit_context *ctxt, gcc_jit_type *numeric_type, int value)); +DEF_DLL_FN (gcc_jit_rvalue *, gcc_jit_lvalue_as_rvalue, + (gcc_jit_lvalue *lvalue)); +DEF_DLL_FN (gcc_jit_rvalue *, gcc_jit_rvalue_access_field, + (gcc_jit_rvalue *struct_or_union, gcc_jit_location *loc, + gcc_jit_field *field)); +DEF_DLL_FN (void, gcc_jit_block_add_comment, + (gcc_jit_block *block, gcc_jit_location *loc, const char *text)); +DEF_DLL_FN (void, gcc_jit_context_release, (gcc_jit_context *ctxt)); +DEF_DLL_FN (const char *, gcc_jit_context_get_first_error, + (gcc_jit_context *ctxt)); +DEF_DLL_FN (gcc_jit_block *, gcc_jit_function_new_block, + (gcc_jit_function *func, const char *name)); +DEF_DLL_FN (gcc_jit_context *, gcc_jit_context_acquire, (void)); +DEF_DLL_FN (gcc_jit_field *, gcc_jit_context_new_field, + (gcc_jit_context *ctxt, gcc_jit_location *loc, gcc_jit_type *type, + const char *name)); +DEF_DLL_FN (gcc_jit_function *, gcc_jit_context_get_builtin_function, + (gcc_jit_context *ctxt, const char *name)); +DEF_DLL_FN (gcc_jit_function *, gcc_jit_context_new_function, + (gcc_jit_context *ctxt, gcc_jit_location *loc, + enum gcc_jit_function_kind kind, gcc_jit_type *return_type, + const char *name, int num_params, gcc_jit_param **params, + int is_variadic)); +DEF_DLL_FN (gcc_jit_lvalue *, gcc_jit_context_new_array_access, + (gcc_jit_context *ctxt, gcc_jit_location *loc, gcc_jit_rvalue *ptr, + gcc_jit_rvalue *index)); +DEF_DLL_FN (gcc_jit_lvalue *, gcc_jit_context_new_global, + (gcc_jit_context *ctxt, gcc_jit_location *loc, + enum gcc_jit_global_kind kind, gcc_jit_type *type, + const char *name)); +DEF_DLL_FN (gcc_jit_lvalue *, gcc_jit_function_new_local, + (gcc_jit_function *func, gcc_jit_location *loc, gcc_jit_type *type, + const char *name)); +DEF_DLL_FN (gcc_jit_lvalue *, gcc_jit_lvalue_access_field, + (gcc_jit_lvalue *struct_or_union, gcc_jit_location *loc, + gcc_jit_field *field)); +DEF_DLL_FN (gcc_jit_lvalue *, gcc_jit_param_as_lvalue, (gcc_jit_param *param)); +DEF_DLL_FN (gcc_jit_lvalue *, gcc_jit_rvalue_dereference, + (gcc_jit_rvalue *rvalue, gcc_jit_location *loc)); +DEF_DLL_FN (gcc_jit_lvalue *, gcc_jit_rvalue_dereference_field, + (gcc_jit_rvalue *ptr, gcc_jit_location *loc, gcc_jit_field *field)); +DEF_DLL_FN (gcc_jit_param *, gcc_jit_context_new_param, + (gcc_jit_context *ctxt, gcc_jit_location *loc, gcc_jit_type *type, + const char *name)); +DEF_DLL_FN (gcc_jit_param *, gcc_jit_function_get_param, + (gcc_jit_function *func, int index)); +DEF_DLL_FN (gcc_jit_rvalue *, gcc_jit_context_new_binary_op, + (gcc_jit_context *ctxt, gcc_jit_location *loc, + enum gcc_jit_binary_op op, gcc_jit_type *result_type, + gcc_jit_rvalue *a, gcc_jit_rvalue *b)); +DEF_DLL_FN (gcc_jit_rvalue *, gcc_jit_context_new_call, + (gcc_jit_context *ctxt, gcc_jit_location *loc, + gcc_jit_function *func, int numargs , gcc_jit_rvalue **args)); +DEF_DLL_FN (gcc_jit_rvalue *, gcc_jit_context_new_call_through_ptr, + (gcc_jit_context *ctxt, gcc_jit_location *loc, + gcc_jit_rvalue *fn_ptr, int numargs, gcc_jit_rvalue **args)); +DEF_DLL_FN (gcc_jit_rvalue *, gcc_jit_context_new_comparison, + (gcc_jit_context *ctxt, gcc_jit_location *loc, + enum gcc_jit_comparison op, gcc_jit_rvalue *a, gcc_jit_rvalue *b)); +DEF_DLL_FN (gcc_jit_rvalue *, gcc_jit_context_new_rvalue_from_long, + (gcc_jit_context *ctxt, gcc_jit_type *numeric_type, long value)); +DEF_DLL_FN (gcc_jit_rvalue *, gcc_jit_context_new_rvalue_from_ptr, + (gcc_jit_context *ctxt, gcc_jit_type *pointer_type, void *value)); +DEF_DLL_FN (gcc_jit_rvalue *, gcc_jit_context_new_unary_op, + (gcc_jit_context *ctxt, gcc_jit_location *loc, + enum gcc_jit_unary_op op, gcc_jit_type *result_type, + gcc_jit_rvalue *rvalue)); +DEF_DLL_FN (gcc_jit_rvalue *, gcc_jit_lvalue_get_address, + (gcc_jit_lvalue *lvalue, gcc_jit_location *loc)); +DEF_DLL_FN (gcc_jit_rvalue *, gcc_jit_param_as_rvalue, (gcc_jit_param *param)); +DEF_DLL_FN (gcc_jit_struct *, gcc_jit_context_new_opaque_struct, + (gcc_jit_context *ctxt, gcc_jit_location *loc, const char *name)); +DEF_DLL_FN (gcc_jit_struct *, gcc_jit_context_new_struct_type, + (gcc_jit_context *ctxt, gcc_jit_location *loc, const char *name, + int num_fields, gcc_jit_field **fields)); +DEF_DLL_FN (gcc_jit_type *, gcc_jit_context_get_int_type, + (gcc_jit_context *ctxt, int num_bytes, int is_signed)); +DEF_DLL_FN (gcc_jit_type *, gcc_jit_context_get_type, + (gcc_jit_context *ctxt, enum gcc_jit_types type_)); +DEF_DLL_FN (gcc_jit_type *, gcc_jit_context_new_array_type, + (gcc_jit_context *ctxt, gcc_jit_location *loc, + gcc_jit_type *element_type, int num_elements)); +DEF_DLL_FN (gcc_jit_type *, gcc_jit_context_new_function_ptr_type, + (gcc_jit_context *ctxt, gcc_jit_location *loc, + gcc_jit_type *return_type, int num_params, + gcc_jit_type **param_types, int is_variadic)); +DEF_DLL_FN (gcc_jit_type *, gcc_jit_context_new_union_type, + (gcc_jit_context *ctxt, gcc_jit_location *loc, const char *name, + int num_fields, gcc_jit_field **fields)); +DEF_DLL_FN (gcc_jit_type *, gcc_jit_rvalue_get_type, (gcc_jit_rvalue *rvalue)); +DEF_DLL_FN (gcc_jit_type *, gcc_jit_struct_as_type, + (gcc_jit_struct *struct_type)); +DEF_DLL_FN (gcc_jit_type *, gcc_jit_type_get_pointer, (gcc_jit_type *type)); +DEF_DLL_FN (void, gcc_jit_block_add_assignment, + (gcc_jit_block *block, gcc_jit_location *loc, gcc_jit_lvalue *lvalue, + gcc_jit_rvalue *rvalue)); +DEF_DLL_FN (void, gcc_jit_block_add_eval, + (gcc_jit_block *block, gcc_jit_location *loc, + gcc_jit_rvalue *rvalue)); +DEF_DLL_FN (void, gcc_jit_block_end_with_conditional, + (gcc_jit_block *block, gcc_jit_location *loc, + gcc_jit_rvalue *boolval, gcc_jit_block *on_true, + gcc_jit_block *on_false)); +DEF_DLL_FN (void, gcc_jit_block_end_with_jump, + (gcc_jit_block *block, gcc_jit_location *loc, + gcc_jit_block *target)); +DEF_DLL_FN (void, gcc_jit_block_end_with_return, + (gcc_jit_block *block, gcc_jit_location *loc, + gcc_jit_rvalue *rvalue)); +DEF_DLL_FN (void, gcc_jit_block_end_with_void_return, + (gcc_jit_block *block, gcc_jit_location *loc)); +DEF_DLL_FN (void, gcc_jit_context_compile_to_file, + (gcc_jit_context *ctxt, enum gcc_jit_output_kind output_kind, + const char *output_path)); +DEF_DLL_FN (void, gcc_jit_context_dump_reproducer_to_file, + (gcc_jit_context *ctxt, const char *path)); +DEF_DLL_FN (void, gcc_jit_context_dump_to_file, + (gcc_jit_context *ctxt, const char *path, int update_locations)); +DEF_DLL_FN (void, gcc_jit_context_set_bool_option, + (gcc_jit_context *ctxt, enum gcc_jit_bool_option opt, int value)); +DEF_DLL_FN (void, gcc_jit_context_set_int_option, + (gcc_jit_context *ctxt, enum gcc_jit_int_option opt, int value)); +DEF_DLL_FN (void, gcc_jit_context_set_logfile, + (gcc_jit_context *ctxt, FILE *logfile, int flags, int verbosity)); +DEF_DLL_FN (void, gcc_jit_struct_set_fields, + (gcc_jit_struct *struct_type, gcc_jit_location *loc, int num_fields, + gcc_jit_field **fields)); + +static bool +init_gccjit_functions (void) +{ + HMODULE library; + + if (!(library = w32_delayed_load (Qgccjit))) + { + return false; + } + + /* In alphabetical order */ + LOAD_DLL_FN(library, gcc_jit_block_add_assignment); + LOAD_DLL_FN(library, gcc_jit_block_add_comment); + LOAD_DLL_FN(library, gcc_jit_block_add_eval); + LOAD_DLL_FN(library, gcc_jit_block_end_with_conditional); + LOAD_DLL_FN(library, gcc_jit_block_end_with_jump); + LOAD_DLL_FN(library, gcc_jit_block_end_with_return); + LOAD_DLL_FN(library, gcc_jit_block_end_with_void_return); + LOAD_DLL_FN(library, gcc_jit_context_acquire); + LOAD_DLL_FN(library, gcc_jit_context_compile_to_file); + LOAD_DLL_FN(library, gcc_jit_context_dump_reproducer_to_file); + LOAD_DLL_FN(library, gcc_jit_context_dump_to_file); + LOAD_DLL_FN(library, gcc_jit_context_get_builtin_function); + LOAD_DLL_FN(library, gcc_jit_context_get_first_error); + LOAD_DLL_FN(library, gcc_jit_context_get_int_type); + LOAD_DLL_FN(library, gcc_jit_context_get_type); + LOAD_DLL_FN(library, gcc_jit_context_new_array_access); + LOAD_DLL_FN(library, gcc_jit_context_new_array_type); + LOAD_DLL_FN(library, gcc_jit_context_new_binary_op); + LOAD_DLL_FN(library, gcc_jit_context_new_call); + LOAD_DLL_FN(library, gcc_jit_context_new_call_through_ptr); + LOAD_DLL_FN(library, gcc_jit_context_new_comparison); + LOAD_DLL_FN(library, gcc_jit_context_new_field); + LOAD_DLL_FN(library, gcc_jit_context_new_function); + LOAD_DLL_FN(library, gcc_jit_context_new_function_ptr_type); + LOAD_DLL_FN(library, gcc_jit_context_new_global); + LOAD_DLL_FN(library, gcc_jit_context_new_opaque_struct); + LOAD_DLL_FN(library, gcc_jit_context_new_param); + LOAD_DLL_FN(library, gcc_jit_context_new_rvalue_from_int); + LOAD_DLL_FN(library, gcc_jit_context_new_rvalue_from_long); + LOAD_DLL_FN(library, gcc_jit_context_new_rvalue_from_ptr); + LOAD_DLL_FN(library, gcc_jit_context_new_struct_type); + LOAD_DLL_FN(library, gcc_jit_context_new_unary_op); + LOAD_DLL_FN(library, gcc_jit_context_new_union_type); + LOAD_DLL_FN(library, gcc_jit_context_release); + LOAD_DLL_FN(library, gcc_jit_context_set_bool_option); + LOAD_DLL_FN(library, gcc_jit_context_set_int_option); + LOAD_DLL_FN(library, gcc_jit_context_set_logfile); + LOAD_DLL_FN(library, gcc_jit_function_get_param); + LOAD_DLL_FN(library, gcc_jit_function_new_block); + LOAD_DLL_FN(library, gcc_jit_function_new_local); + LOAD_DLL_FN(library, gcc_jit_lvalue_access_field); + LOAD_DLL_FN(library, gcc_jit_lvalue_as_rvalue); + LOAD_DLL_FN(library, gcc_jit_lvalue_get_address); + LOAD_DLL_FN(library, gcc_jit_param_as_lvalue); + LOAD_DLL_FN(library, gcc_jit_param_as_rvalue); + LOAD_DLL_FN(library, gcc_jit_rvalue_access_field); + LOAD_DLL_FN(library, gcc_jit_rvalue_dereference); + LOAD_DLL_FN(library, gcc_jit_rvalue_dereference_field); + LOAD_DLL_FN(library, gcc_jit_rvalue_get_type); + LOAD_DLL_FN(library, gcc_jit_struct_as_type); + LOAD_DLL_FN(library, gcc_jit_struct_set_fields); + LOAD_DLL_FN(library, gcc_jit_type_get_pointer); + + return true; +} + +/* In alphabetical order */ +#define gcc_jit_block_add_assignment fn_gcc_jit_block_add_assignment +#define gcc_jit_block_add_comment fn_gcc_jit_block_add_comment +#define gcc_jit_block_add_eval fn_gcc_jit_block_add_eval +#define gcc_jit_block_end_with_conditional fn_gcc_jit_block_end_with_conditional +#define gcc_jit_block_end_with_jump fn_gcc_jit_block_end_with_jump +#define gcc_jit_block_end_with_return fn_gcc_jit_block_end_with_return +#define gcc_jit_block_end_with_void_return fn_gcc_jit_block_end_with_void_return +#define gcc_jit_context_acquire fn_gcc_jit_context_acquire +#define gcc_jit_context_compile_to_file fn_gcc_jit_context_compile_to_file +#define gcc_jit_context_dump_reproducer_to_file fn_gcc_jit_context_dump_reproducer_to_file +#define gcc_jit_context_dump_to_file fn_gcc_jit_context_dump_to_file +#define gcc_jit_context_get_builtin_function fn_gcc_jit_context_get_builtin_function +#define gcc_jit_context_get_first_error fn_gcc_jit_context_get_first_error +#define gcc_jit_context_get_int_type fn_gcc_jit_context_get_int_type +#define gcc_jit_context_get_type fn_gcc_jit_context_get_type +#define gcc_jit_context_new_array_access fn_gcc_jit_context_new_array_access +#define gcc_jit_context_new_array_type fn_gcc_jit_context_new_array_type +#define gcc_jit_context_new_binary_op fn_gcc_jit_context_new_binary_op +#define gcc_jit_context_new_call fn_gcc_jit_context_new_call +#define gcc_jit_context_new_call_through_ptr fn_gcc_jit_context_new_call_through_ptr +#define gcc_jit_context_new_comparison fn_gcc_jit_context_new_comparison +#define gcc_jit_context_new_field fn_gcc_jit_context_new_field +#define gcc_jit_context_new_function fn_gcc_jit_context_new_function +#define gcc_jit_context_new_function_ptr_type fn_gcc_jit_context_new_function_ptr_type +#define gcc_jit_context_new_global fn_gcc_jit_context_new_global +#define gcc_jit_context_new_opaque_struct fn_gcc_jit_context_new_opaque_struct +#define gcc_jit_context_new_param fn_gcc_jit_context_new_param +#define gcc_jit_context_new_rvalue_from_int fn_gcc_jit_context_new_rvalue_from_int +#define gcc_jit_context_new_rvalue_from_long fn_gcc_jit_context_new_rvalue_from_long +#define gcc_jit_context_new_rvalue_from_ptr fn_gcc_jit_context_new_rvalue_from_ptr +#define gcc_jit_context_new_struct_type fn_gcc_jit_context_new_struct_type +#define gcc_jit_context_new_unary_op fn_gcc_jit_context_new_unary_op +#define gcc_jit_context_new_union_type fn_gcc_jit_context_new_union_type +#define gcc_jit_context_release fn_gcc_jit_context_release +#define gcc_jit_context_set_bool_option fn_gcc_jit_context_set_bool_option +#define gcc_jit_context_set_int_option fn_gcc_jit_context_set_int_option +#define gcc_jit_context_set_logfile fn_gcc_jit_context_set_logfile +#define gcc_jit_function_get_param fn_gcc_jit_function_get_param +#define gcc_jit_function_new_block fn_gcc_jit_function_new_block +#define gcc_jit_function_new_local fn_gcc_jit_function_new_local +#define gcc_jit_lvalue_access_field fn_gcc_jit_lvalue_access_field +#define gcc_jit_lvalue_as_rvalue fn_gcc_jit_lvalue_as_rvalue +#define gcc_jit_lvalue_get_address fn_gcc_jit_lvalue_get_address +#define gcc_jit_param_as_lvalue fn_gcc_jit_param_as_lvalue +#define gcc_jit_param_as_rvalue fn_gcc_jit_param_as_rvalue +#define gcc_jit_rvalue_access_field fn_gcc_jit_rvalue_access_field +#define gcc_jit_rvalue_dereference fn_gcc_jit_rvalue_dereference +#define gcc_jit_rvalue_dereference_field fn_gcc_jit_rvalue_dereference_field +#define gcc_jit_rvalue_get_type fn_gcc_jit_rvalue_get_type +#define gcc_jit_struct_as_type fn_gcc_jit_struct_as_type +#define gcc_jit_struct_set_fields fn_gcc_jit_struct_set_fields +#define gcc_jit_type_get_pointer fn_gcc_jit_type_get_pointer + +#endif + +static bool +load_gccjit_if_necessary (bool mandatory) +{ +#ifdef WINDOWSNT + static bool tried_to_initialize_once; + static bool gccjit_initialized; + + if (!tried_to_initialize_once) + { + tried_to_initialize_once = true; + Lisp_Object status; + gccjit_initialized = init_gccjit_functions (); + status = gccjit_initialized ? Qt : Qnil; + Vlibrary_cache = Fcons (Fcons (Qgccjit, status), Vlibrary_cache); + } + + if (mandatory && !gccjit_initialized) + xsignal1(Qnative_compiler_error, build_string("libgccjit not found")); + + return gccjit_initialized; +#else + return true; +#endif +} + + /* C symbols emitted for the load relocation mechanism. */ #define CURRENT_THREAD_RELOC_SYM "current_thread_reloc" #define PURE_RELOC_SYM "pure_reloc" @@ -3295,6 +3637,8 @@ DEFUN ("comp--init-ctxt", Fcomp__init_ctxt, Scomp__init_ctxt, doc: /* Initialize the native compiler context. Return t on success. */) (void) { + load_gccjit_if_necessary(true); + if (comp.ctxt) { xsignal1 (Qnative_ice, @@ -3441,6 +3785,8 @@ DEFUN ("comp--release-ctxt", Fcomp__release_ctxt, Scomp__release_ctxt, doc: /* Release the native compiler context. */) (void) { + load_gccjit_if_necessary(true); + if (comp.ctxt) gcc_jit_context_release (comp.ctxt); @@ -3457,6 +3803,8 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, doc: /* Compile as native code the current context to file. */) (Lisp_Object base_name) { + load_gccjit_if_necessary(true); + CHECK_STRING (base_name); gcc_jit_context_set_int_option (comp.ctxt, @@ -3626,6 +3974,9 @@ maybe_defer_native_compilation (Lisp_Object function_name, fflush (f); } #endif + if (!load_gccjit_if_necessary(false)) + return; + if (!comp_deferred_compilation || noninteractive || !NILP (Vpurify_flag) @@ -3975,10 +4326,26 @@ DEFUN ("native-elisp-load", Fnative_elisp_load, Snative_elisp_load, 1, 2, 0, return Qt; } +#endif /* HAVE_NATIVE_COMP */ + +DEFUN ("native-comp-available-p", Fnative_comp_available_p, + Snative_comp_available_p, 0, 0, 0, + doc: /* Returns t if native compilation of Lisp files is available in +this instance of Emacs. */) + (void) +{ +#ifdef HAVE_NATIVE_COMP + return load_gccjit_if_necessary(false) ? Qt : Qnil; +#else + return Qnil; +#endif +} + void syms_of_comp (void) { +#ifdef HAVE_NATIVE_COMP /* Compiler control customizes. */ DEFVAR_BOOL ("comp-deferred-compilation", comp_deferred_compilation, doc: /* If t compile asyncronously every .elc file loaded. */); @@ -4122,6 +4489,7 @@ syms_of_comp (void) doc: /* Hash table symbol-name -> function-value. For internal use during */); Vcomp_deferred_pending_h = CALLN (Fmake_hash_table, QCtest, Qeq); -} +#endif -#endif /* HAVE_NATIVE_COMP */ + defsubr (&Snative_comp_available_p); +} diff --git a/src/comp.h b/src/comp.h index b03a805514..36e7cdf441 100644 --- a/src/comp.h +++ b/src/comp.h @@ -90,11 +90,7 @@ maybe_defer_native_compilation (Lisp_Object function_name, Lisp_Object definition) {} -static inline Lisp_Object -Fnative_elisp_load (Lisp_Object file, Lisp_Object late_load) -{ - eassume (false); -} +extern void syms_of_comp (void); #endif diff --git a/src/emacs.c b/src/emacs.c index 2c90825742..e75cb58834 100644 --- a/src/emacs.c +++ b/src/emacs.c @@ -1606,10 +1606,8 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem init_json (); #endif -#ifdef HAVE_NATIVE_COMP if (!initialized) syms_of_comp (); -#endif no_loadup = argmatch (argv, argc, "-nl", "--no-loadup", 6, NULL, &skip_args); diff --git a/src/w32.c b/src/w32.c index 0f69e652a5..d01a45029d 100644 --- a/src/w32.c +++ b/src/w32.c @@ -10586,6 +10586,10 @@ globals_of_w32 (void) #endif w32_crypto_hprov = (HCRYPTPROV)0; + + /* We need to forget about libraries that were loaded during the + dumping process (e.g. libgccjit) */ + Vlibrary_cache = Qnil; } /* For make-serial-process */ diff --git a/src/w32fns.c b/src/w32fns.c index e595b0285a..eeb73489dd 100644 --- a/src/w32fns.c +++ b/src/w32fns.c @@ -10462,6 +10462,7 @@ syms_of_w32fns (void) DEFSYM (Qzlib, "zlib"); DEFSYM (Qlcms2, "lcms2"); DEFSYM (Qjson, "json"); + DEFSYM (Qgccjit, "gccjit"); Fput (Qundefined_color, Qerror_conditions, pure_list (Qundefined_color, Qerror)); commit 0a2ac47909c497d299e5d5cc111cf77206dcda9b Author: Andrea Corallo Date: Thu May 21 17:51:31 2020 +0100 * src/comp.c: Fix 32bit wide-int. * src/comp.c (emit_XFIXNUM): Make right shift for MSB_TAG arithmetic too to preserve sign bit. diff --git a/src/comp.c b/src/comp.c index 6371757487..994bd7db93 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1066,6 +1066,8 @@ emit_XFIXNUM (gcc_jit_rvalue *obj) emit_comment ("XFIXNUM"); gcc_jit_rvalue *i = emit_coerce (comp.emacs_uint_type, emit_XLI (obj)); + /* FIXME: Implementation dependent (both RSHIFT are arithmetics). */ + if (!USE_LSB_TAG) { i = emit_binary_op (GCC_JIT_BINARY_OP_LSHIFT, @@ -1073,14 +1075,12 @@ emit_XFIXNUM (gcc_jit_rvalue *obj) i, comp.inttypebits); - return emit_coerce (comp.emacs_int_type, - emit_binary_op (GCC_JIT_BINARY_OP_RSHIFT, - comp.emacs_uint_type, - i, - comp.inttypebits)); + return emit_binary_op (GCC_JIT_BINARY_OP_RSHIFT, + comp.emacs_int_type, + i, + comp.inttypebits); } else - /* FIXME: Implementation dependent (wants arithmetic shift). */ return emit_coerce (comp.emacs_int_type, emit_binary_op (GCC_JIT_BINARY_OP_RSHIFT, comp.emacs_int_type, commit f036ec97cecc8d7ec2cd36741bbe2619cda1207b Author: Andrea Corallo Date: Thu May 21 14:38:51 2020 +0100 * src/comp.c: Fix i386 --enable-check-lisp-object-type * src/comp.c (load_comp_unit): Fix return type, on i386 influence parameter passing! diff --git a/src/comp.c b/src/comp.c index 14862228ab..6371757487 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3755,7 +3755,7 @@ load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u, bool loading_dump, freloc_check_fill (); - void (*top_level_run)(Lisp_Object) + Lisp_Object (*top_level_run)(Lisp_Object) = dynlib_sym (handle, late_load ? "late_top_level_run" : "top_level_run"); commit 38a9ddbc1c656cfaab2c7660f7dab9b0587ecfef Author: Andrea Corallo Date: Wed May 20 21:03:29 2020 +0100 * src/comp.c: Some aesthetic code clean-up. * src/comp.c (comp_t): Remove 'lisp_X_s' field. (emit_coerce): Respect 80 columns limit. (emit_rvalue_from_emacs_uint): GNU style, unnecessary brackets. (emit_rvalue_from_emacs_int): Likewise. (emit_rvalue_from_lisp_word_tag): Likewise. (emit_rvalue_from_lisp_word): Likewise. (emit_lval_XLI): Remove unused function. (emit_lval_XLP): Remove commented out code. (define_add1_sub1): Respect 80 columns limit. (Fcomp__init_ctxt): Reflect 'lisp_X_s' field removal. diff --git a/src/comp.c b/src/comp.c index acb018bab7..14862228ab 100644 --- a/src/comp.c +++ b/src/comp.c @@ -117,7 +117,6 @@ typedef struct { gcc_jit_type *ptrdiff_type; gcc_jit_type *uintptr_type; #if LISP_WORDS_ARE_POINTERS - gcc_jit_struct *lisp_X_s; gcc_jit_type *lisp_X; #endif gcc_jit_type *lisp_word_type; @@ -650,14 +649,15 @@ emit_coerce (gcc_jit_type *new_type, gcc_jit_rvalue *obj) gcc_jit_rvalue *lwordobj = emit_coerce (comp.lisp_word_type, obj); - gcc_jit_lvalue *tmp_s - = gcc_jit_function_new_local (comp.func, NULL, comp.lisp_obj_type, - format_string ("lisp_obj_%td", i++)); + gcc_jit_lvalue *tmp_s = + gcc_jit_function_new_local (comp.func, NULL, comp.lisp_obj_type, + format_string ("lisp_obj_%td", i++)); - gcc_jit_block_add_assignment (comp.block, NULL, - gcc_jit_lvalue_access_field (tmp_s, NULL, - comp.lisp_obj_i), - lwordobj); + gcc_jit_block_add_assignment ( + comp.block, NULL, + gcc_jit_lvalue_access_field (tmp_s, NULL, + comp.lisp_obj_i), + lwordobj); return gcc_jit_lvalue_as_rvalue (tmp_s); } #endif @@ -786,44 +786,32 @@ static gcc_jit_rvalue * emit_rvalue_from_emacs_uint (EMACS_UINT val) { if (val != (long) val) - { - return emit_rvalue_from_unsigned_long_long (comp.emacs_uint_type, val); - } + return emit_rvalue_from_unsigned_long_long (comp.emacs_uint_type, val); else - { - return gcc_jit_context_new_rvalue_from_long (comp.ctxt, - comp.emacs_uint_type, - val); - } + return gcc_jit_context_new_rvalue_from_long (comp.ctxt, + comp.emacs_uint_type, + val); } static gcc_jit_rvalue * emit_rvalue_from_emacs_int (EMACS_INT val) { if (val != (long) val) - { - return emit_rvalue_from_long_long (comp.emacs_int_type, val); - } + return emit_rvalue_from_long_long (comp.emacs_int_type, val); else - { - return gcc_jit_context_new_rvalue_from_long (comp.ctxt, - comp.emacs_int_type, val); - } + return gcc_jit_context_new_rvalue_from_long (comp.ctxt, + comp.emacs_int_type, val); } static gcc_jit_rvalue * emit_rvalue_from_lisp_word_tag (Lisp_Word_tag val) { if (val != (long) val) - { - return emit_rvalue_from_unsigned_long_long (comp.lisp_word_tag_type, val); - } + return emit_rvalue_from_unsigned_long_long (comp.lisp_word_tag_type, val); else - { - return gcc_jit_context_new_rvalue_from_long (comp.ctxt, - comp.lisp_word_tag_type, - val); - } + return gcc_jit_context_new_rvalue_from_long (comp.ctxt, + comp.lisp_word_tag_type, + val); } static gcc_jit_rvalue * @@ -835,15 +823,11 @@ emit_rvalue_from_lisp_word (Lisp_Word val) val); #else if (val != (long) val) - { - return emit_rvalue_from_unsigned_long_long (comp.lisp_word_type, val); - } + return emit_rvalue_from_unsigned_long_long (comp.lisp_word_type, val); else - { - return gcc_jit_context_new_rvalue_from_long (comp.ctxt, - comp.lisp_word_type, - val); - } + return gcc_jit_context_new_rvalue_from_long (comp.ctxt, + comp.lisp_word_type, + val); #endif } @@ -895,14 +879,6 @@ emit_XLI (gcc_jit_rvalue *obj) return emit_coerce (comp.emacs_int_type, obj); } -static gcc_jit_lvalue * -emit_lval_XLI (gcc_jit_lvalue *obj) -{ - emit_comment ("lval_XLI"); - return obj; -} - - static gcc_jit_rvalue * emit_XLP (gcc_jit_rvalue *obj) { @@ -911,17 +887,6 @@ emit_XLP (gcc_jit_rvalue *obj) return emit_coerce (comp.void_ptr_type, obj); } -/* TODO */ -/* static gcc_jit_lvalue * */ -/* emit_lval_XLP (gcc_jit_lvalue *obj) */ -/* { */ -/* emit_comment ("lval_XLP"); */ - -/* return gcc_jit_lvalue_access_field (obj, */ -/* NULL, */ -/* comp.lisp_obj_as_ptr); */ -/* } */ - static gcc_jit_rvalue * emit_XUNTAG (gcc_jit_rvalue *a, gcc_jit_type *type, Lisp_Word_tag lisp_word_tag) { @@ -2912,13 +2877,14 @@ define_add1_sub1 (void) GCC_JIT_BINARY_OP_LOGICAL_AND, comp.bool_type, sure_fixnum, - gcc_jit_context_new_comparison (comp.ctxt, - NULL, - GCC_JIT_COMPARISON_NE, - n_fixnum, - i == 0 - ? emit_rvalue_from_emacs_int (MOST_POSITIVE_FIXNUM) - : emit_rvalue_from_emacs_int (MOST_NEGATIVE_FIXNUM))), + gcc_jit_context_new_comparison ( + comp.ctxt, + NULL, + GCC_JIT_COMPARISON_NE, + n_fixnum, + i == 0 + ? emit_rvalue_from_emacs_int (MOST_POSITIVE_FIXNUM) + : emit_rvalue_from_emacs_int (MOST_NEGATIVE_FIXNUM))), inline_block, fcall_block); @@ -3408,10 +3374,10 @@ DEFUN ("comp--init-ctxt", Fcomp__init_ctxt, Scomp__init_ctxt, sizeof (EMACS_UINT), false); #if LISP_WORDS_ARE_POINTERS - comp.lisp_X_s = gcc_jit_context_new_opaque_struct (comp.ctxt, - NULL, - "Lisp_X"); - comp.lisp_X = gcc_jit_struct_as_type (comp.lisp_X_s); + comp.lisp_X = + gcc_jit_struct_as_type (gcc_jit_context_new_opaque_struct (comp.ctxt, + NULL, + "Lisp_X")); comp.lisp_word_type = gcc_jit_type_get_pointer (comp.lisp_X); #else comp.lisp_word_type = comp.emacs_int_type; commit 7fa83f9ac96bd201a15f7b0ae4a2cd20a70fd7ef Author: Nicolás Bértolo Date: Fri May 8 14:30:14 2020 -0300 Handle LISP_WORDS_ARE_POINTERS and CHECK_LISP_OBJECT_TYPE. * src/comp.c: Introduce the Lisp_X, Lisp_Word, and Lisp_Word_tag types. These types are used instead of long or long long. Use emacs_int_type and emacs_uint_types where appropriate. (emit_coerce): Add special logic that handles the case when Lisp_Object is a struct. This is necessary for handling the --enable-check-lisp-object-type configure option. * src/lisp.h: Since libgccjit does not support opaque unions, change Lisp_X to be struct. This is done to ensure that the same types are used in the same binary. It is probably unnecessary since only a pointer to it is used. diff --git a/src/comp.c b/src/comp.c index 15dd0487c0..acb018bab7 100644 --- a/src/comp.c +++ b/src/comp.c @@ -116,6 +116,16 @@ typedef struct { gcc_jit_type *char_ptr_type; gcc_jit_type *ptrdiff_type; gcc_jit_type *uintptr_type; +#if LISP_WORDS_ARE_POINTERS + gcc_jit_struct *lisp_X_s; + gcc_jit_type *lisp_X; +#endif + gcc_jit_type *lisp_word_type; + gcc_jit_type *lisp_word_tag_type; +#ifdef LISP_OBJECT_IS_STRUCT + gcc_jit_field *lisp_obj_i; + gcc_jit_struct *lisp_obj_s; +#endif gcc_jit_type *lisp_obj_type; gcc_jit_type *lisp_obj_ptr_type; /* struct Lisp_Cons */ @@ -158,7 +168,8 @@ typedef struct { gcc_jit_field *cast_union_as_c_p; gcc_jit_field *cast_union_as_v_p; gcc_jit_field *cast_union_as_lisp_cons_ptr; - gcc_jit_field *cast_union_as_lisp_obj; + gcc_jit_field *cast_union_as_lisp_word; + gcc_jit_field *cast_union_as_lisp_word_tag; gcc_jit_field *cast_union_as_lisp_obj_ptr; gcc_jit_function *func; /* Current function being compiled. */ bool func_has_non_local; /* From comp-func has-non-local slot. */ @@ -344,8 +355,10 @@ type_to_cast_field (gcc_jit_type *type) field = comp.cast_union_as_c_p; else if (type == comp.lisp_cons_ptr_type) field = comp.cast_union_as_lisp_cons_ptr; - else if (type == comp.lisp_obj_type) - field = comp.cast_union_as_lisp_obj; + else if (type == comp.lisp_word_type) + field = comp.cast_union_as_lisp_word; + else if (type == comp.lisp_word_tag_type) + field = comp.cast_union_as_lisp_word_tag; else if (type == comp.lisp_obj_ptr_type) field = comp.cast_union_as_lisp_obj_ptr; else @@ -624,6 +637,31 @@ emit_coerce (gcc_jit_type *new_type, gcc_jit_rvalue *obj) if (new_type == old_type) return obj; +#ifdef LISP_OBJECT_IS_STRUCT + if (old_type == comp.lisp_obj_type) + { + gcc_jit_rvalue *lwordobj = + gcc_jit_rvalue_access_field (obj, NULL, comp.lisp_obj_i); + return emit_coerce (new_type, lwordobj); + } + + if (new_type == comp.lisp_obj_type) + { + gcc_jit_rvalue *lwordobj = + emit_coerce (comp.lisp_word_type, obj); + + gcc_jit_lvalue *tmp_s + = gcc_jit_function_new_local (comp.func, NULL, comp.lisp_obj_type, + format_string ("lisp_obj_%td", i++)); + + gcc_jit_block_add_assignment (comp.block, NULL, + gcc_jit_lvalue_access_field (tmp_s, NULL, + comp.lisp_obj_i), + lwordobj); + return gcc_jit_lvalue_as_rvalue (tmp_s); + } +#endif + gcc_jit_field *orig_field = type_to_cast_field (old_type); gcc_jit_field *dest_field = type_to_cast_field (new_type); @@ -661,14 +699,8 @@ emit_binary_op (enum gcc_jit_binary_op op, /* Should come with libgccjit. */ static gcc_jit_rvalue * -emit_rvalue_from_long_long (long long n) +emit_rvalue_from_long_long (gcc_jit_type *type, long long n) { -#ifndef WIDE_EMACS_INT - xsignal1 (Qnative_ice, - build_string ("emit_rvalue_from_long_long called in non wide int" - " configuration")); -#endif - emit_comment (format_string ("emit long long: %lld", n)); gcc_jit_rvalue *high = @@ -694,7 +726,7 @@ emit_rvalue_from_long_long (long long n) 32)); return - emit_coerce (comp.long_long_type, + emit_coerce (type, emit_binary_op ( GCC_JIT_BINARY_OP_BITWISE_OR, comp.unsigned_long_long_type, @@ -709,26 +741,120 @@ emit_rvalue_from_long_long (long long n) } static gcc_jit_rvalue * -emit_most_positive_fixnum (void) +emit_rvalue_from_unsigned_long_long (gcc_jit_type *type, unsigned long long n) +{ + emit_comment (format_string ("emit unsigned long long: %llu", n)); + + gcc_jit_rvalue *high = + gcc_jit_context_new_rvalue_from_long (comp.ctxt, + comp.unsigned_long_long_type, + n >> 32); + gcc_jit_rvalue *low = + emit_binary_op (GCC_JIT_BINARY_OP_RSHIFT, + comp.unsigned_long_long_type, + emit_binary_op (GCC_JIT_BINARY_OP_LSHIFT, + comp.unsigned_long_long_type, + gcc_jit_context_new_rvalue_from_long ( + comp.ctxt, + comp.unsigned_long_long_type, + n), + gcc_jit_context_new_rvalue_from_int ( + comp.ctxt, + comp.unsigned_long_long_type, + 32)), + gcc_jit_context_new_rvalue_from_int ( + comp.ctxt, + comp.unsigned_long_long_type, + 32)); + + return emit_coerce ( + type, + emit_binary_op ( + GCC_JIT_BINARY_OP_BITWISE_OR, + comp.unsigned_long_long_type, + emit_binary_op ( + GCC_JIT_BINARY_OP_LSHIFT, + comp.unsigned_long_long_type, + high, + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.unsigned_long_long_type, + 32)), + low)); +} + +static gcc_jit_rvalue * +emit_rvalue_from_emacs_uint (EMACS_UINT val) +{ + if (val != (long) val) + { + return emit_rvalue_from_unsigned_long_long (comp.emacs_uint_type, val); + } + else + { + return gcc_jit_context_new_rvalue_from_long (comp.ctxt, + comp.emacs_uint_type, + val); + } +} + +static gcc_jit_rvalue * +emit_rvalue_from_emacs_int (EMACS_INT val) +{ + if (val != (long) val) + { + return emit_rvalue_from_long_long (comp.emacs_int_type, val); + } + else + { + return gcc_jit_context_new_rvalue_from_long (comp.ctxt, + comp.emacs_int_type, val); + } +} + +static gcc_jit_rvalue * +emit_rvalue_from_lisp_word_tag (Lisp_Word_tag val) +{ + if (val != (long) val) + { + return emit_rvalue_from_unsigned_long_long (comp.lisp_word_tag_type, val); + } + else + { + return gcc_jit_context_new_rvalue_from_long (comp.ctxt, + comp.lisp_word_tag_type, + val); + } +} + +static gcc_jit_rvalue * +emit_rvalue_from_lisp_word (Lisp_Word val) { -#if EMACS_INT_MAX > LONG_MAX - return emit_rvalue_from_long_long (MOST_POSITIVE_FIXNUM); +#if LISP_WORDS_ARE_POINTERS + return gcc_jit_context_new_rvalue_from_ptr (comp.ctxt, + comp.lisp_word_type, + val); #else - return gcc_jit_context_new_rvalue_from_long (comp.ctxt, - comp.emacs_int_type, - MOST_POSITIVE_FIXNUM); + if (val != (long) val) + { + return emit_rvalue_from_unsigned_long_long (comp.lisp_word_type, val); + } + else + { + return gcc_jit_context_new_rvalue_from_long (comp.ctxt, + comp.lisp_word_type, + val); + } #endif } static gcc_jit_rvalue * -emit_most_negative_fixnum (void) +emit_rvalue_from_lisp_obj (Lisp_Object obj) { -#if EMACS_INT_MAX > LONG_MAX - return emit_rvalue_from_long_long (MOST_NEGATIVE_FIXNUM); +#ifdef LISP_OBJECT_IS_STRUCT + return emit_coerce (comp.lisp_obj_type, + emit_rvalue_from_lisp_word (obj.i)); #else - return gcc_jit_context_new_rvalue_from_long (comp.ctxt, - comp.emacs_int_type, - MOST_NEGATIVE_FIXNUM); + return emit_rvalue_from_lisp_word (obj); #endif } @@ -766,7 +892,7 @@ static gcc_jit_rvalue * emit_XLI (gcc_jit_rvalue *obj) { emit_comment ("XLI"); - return obj; + return emit_coerce (comp.emacs_int_type, obj); } static gcc_jit_lvalue * @@ -776,54 +902,40 @@ emit_lval_XLI (gcc_jit_lvalue *obj) return obj; } -/* + static gcc_jit_rvalue * emit_XLP (gcc_jit_rvalue *obj) { emit_comment ("XLP"); - return gcc_jit_rvalue_access_field (obj, - NULL, - comp.lisp_obj_as_ptr); + return emit_coerce (comp.void_ptr_type, obj); } -static gcc_jit_lvalue * -emit_lval_XLP (gcc_jit_lvalue *obj) -{ - emit_comment ("lval_XLP"); +/* TODO */ +/* static gcc_jit_lvalue * */ +/* emit_lval_XLP (gcc_jit_lvalue *obj) */ +/* { */ +/* emit_comment ("lval_XLP"); */ + +/* return gcc_jit_lvalue_access_field (obj, */ +/* NULL, */ +/* comp.lisp_obj_as_ptr); */ +/* } */ - return gcc_jit_lvalue_access_field (obj, - NULL, - comp.lisp_obj_as_ptr); -} */ static gcc_jit_rvalue * -emit_XUNTAG (gcc_jit_rvalue *a, gcc_jit_type *type, long long lisp_word_tag) +emit_XUNTAG (gcc_jit_rvalue *a, gcc_jit_type *type, Lisp_Word_tag lisp_word_tag) { /* #define XUNTAG(a, type, ctype) ((ctype *) ((char *) XLP (a) - LISP_WORD_TAG (type))) */ emit_comment ("XUNTAG"); -#ifndef WIDE_EMACS_INT return emit_coerce ( gcc_jit_type_get_pointer (type), emit_binary_op ( GCC_JIT_BINARY_OP_MINUS, - comp.emacs_int_type, - emit_XLI (a), - gcc_jit_context_new_rvalue_from_int ( - comp.ctxt, - comp.emacs_int_type, - lisp_word_tag))); -#else - return emit_coerce ( - gcc_jit_type_get_pointer (type), - emit_binary_op ( - GCC_JIT_BINARY_OP_MINUS, - comp.unsigned_long_long_type, - /* FIXME Should be XLP. */ - emit_XLI (a), - emit_rvalue_from_long_long (lisp_word_tag))); -#endif + comp.uintptr_type, + emit_XLP (a), + emit_rvalue_from_lisp_word_tag(lisp_word_tag))); } static gcc_jit_rvalue * @@ -850,7 +962,7 @@ emit_EQ (gcc_jit_rvalue *x, gcc_jit_rvalue *y) } static gcc_jit_rvalue * -emit_TAGGEDP (gcc_jit_rvalue *obj, ptrdiff_t tag) +emit_TAGGEDP (gcc_jit_rvalue *obj, Lisp_Word_tag tag) { /* (! (((unsigned) (XLI (a) >> (USE_LSB_TAG ? 0 : VALBITS)) \ - (unsigned) (tag)) \ @@ -1051,17 +1163,7 @@ emit_make_fixnum_LSB_TAG (gcc_jit_rvalue *n) comp.emacs_int_type, tmp, comp.lisp_int0); - gcc_jit_lvalue *res = gcc_jit_function_new_local (comp.func, - NULL, - comp.lisp_obj_type, - "lisp_obj_fixnum"); - - gcc_jit_block_add_assignment (comp.block, - NULL, - emit_lval_XLI (res), - tmp); - - return gcc_jit_lvalue_as_rvalue (res); + return emit_coerce (comp.lisp_obj_type, tmp); } static gcc_jit_rvalue * @@ -1073,10 +1175,8 @@ emit_make_fixnum_MSB_TAG (gcc_jit_rvalue *n) return XIL (n); */ - gcc_jit_rvalue *intmask = - emit_coerce (comp.emacs_uint_type, - emit_rvalue_from_long_long ((EMACS_INT_MAX - >> (INTTYPEBITS - 1)))); + gcc_jit_rvalue *intmask = emit_rvalue_from_emacs_uint (INTMASK); + n = emit_binary_op (GCC_JIT_BINARY_OP_BITWISE_AND, comp.emacs_uint_type, intmask, n); @@ -1087,12 +1187,10 @@ emit_make_fixnum_MSB_TAG (gcc_jit_rvalue *n) emit_binary_op (GCC_JIT_BINARY_OP_LSHIFT, comp.emacs_uint_type, comp.lisp_int0, - gcc_jit_context_new_rvalue_from_int ( - comp.ctxt, - comp.emacs_uint_type, - VALBITS)), + emit_rvalue_from_emacs_uint (VALBITS)), n); - return emit_XLI (emit_coerce (comp.emacs_int_type, n)); + + return emit_coerce (comp.lisp_obj_type, n); } @@ -1124,17 +1222,10 @@ emit_lisp_obj_rval (Lisp_Object obj) emit_comment (format_string ("const lisp obj: %s", SSDATA (Fprin1_to_string (obj, Qnil)))); - if (NIL_IS_ZERO && EQ (obj, Qnil)) + if (EQ (obj, Qnil)) { gcc_jit_rvalue *n; -#ifdef WIDE_EMACS_INT - eassert (NIL_IS_ZERO); - n = emit_rvalue_from_long_long (0); -#else - n = gcc_jit_context_new_rvalue_from_ptr (comp.ctxt, - comp.void_ptr_type, - NULL); -#endif + n = emit_rvalue_from_lisp_word ((Lisp_Word) iQnil); return emit_coerce (comp.lisp_obj_type, n); } @@ -1360,16 +1451,7 @@ emit_mvar_rval (Lisp_Object mvar) { /* We can still emit directly objects that are self-contained in a word (read fixnums). */ - gcc_jit_rvalue *word; -#ifdef WIDE_EMACS_INT - word = emit_rvalue_from_long_long (constant); -#else - word = - gcc_jit_context_new_rvalue_from_ptr (comp.ctxt, - comp.void_ptr_type, - XLP (constant)); -#endif - return emit_coerce (comp.lisp_obj_type, word); + return emit_rvalue_from_lisp_obj (constant); } /* Other const objects are fetched from the reloc array. */ return emit_lisp_obj_rval (constant); @@ -2537,11 +2619,16 @@ define_cast_union (void) NULL, comp.lisp_cons_ptr_type, "cons_ptr"); - comp.cast_union_as_lisp_obj = + comp.cast_union_as_lisp_word = gcc_jit_context_new_field (comp.ctxt, NULL, - comp.lisp_obj_type, - "lisp_obj"); + comp.lisp_word_type, + "lisp_word"); + comp.cast_union_as_lisp_word_tag = + gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.lisp_word_tag_type, + "lisp_word_tag"); comp.cast_union_as_lisp_obj_ptr = gcc_jit_context_new_field (comp.ctxt, NULL, @@ -2562,7 +2649,8 @@ define_cast_union (void) comp.cast_union_as_c_p, comp.cast_union_as_v_p, comp.cast_union_as_lisp_cons_ptr, - comp.cast_union_as_lisp_obj, + comp.cast_union_as_lisp_word, + comp.cast_union_as_lisp_word_tag, comp.cast_union_as_lisp_obj_ptr }; comp.cast_union_type = gcc_jit_context_new_union_type (comp.ctxt, @@ -2829,8 +2917,8 @@ define_add1_sub1 (void) GCC_JIT_COMPARISON_NE, n_fixnum, i == 0 - ? emit_most_positive_fixnum () - : emit_most_negative_fixnum ())), + ? emit_rvalue_from_emacs_int (MOST_POSITIVE_FIXNUM) + : emit_rvalue_from_emacs_int (MOST_NEGATIVE_FIXNUM))), inline_block, fcall_block); @@ -2900,7 +2988,8 @@ define_negate (void) NULL, GCC_JIT_COMPARISON_NE, n_fixnum, - emit_most_negative_fixnum ())), + emit_rvalue_from_emacs_int ( + MOST_NEGATIVE_FIXNUM))), inline_block, fcall_block); @@ -3318,9 +3407,31 @@ DEFUN ("comp--init-ctxt", Fcomp__init_ctxt, Scomp__init_ctxt, comp.emacs_uint_type = gcc_jit_context_get_int_type (comp.ctxt, sizeof (EMACS_UINT), false); - /* No XLP is emitted for now so lets define this always as integer - disregarding LISP_WORDS_ARE_POINTERS value. */ - comp.lisp_obj_type = comp.emacs_int_type; +#if LISP_WORDS_ARE_POINTERS + comp.lisp_X_s = gcc_jit_context_new_opaque_struct (comp.ctxt, + NULL, + "Lisp_X"); + comp.lisp_X = gcc_jit_struct_as_type (comp.lisp_X_s); + comp.lisp_word_type = gcc_jit_type_get_pointer (comp.lisp_X); +#else + comp.lisp_word_type = comp.emacs_int_type; +#endif + comp.lisp_word_tag_type + = gcc_jit_context_get_int_type (comp.ctxt, sizeof (Lisp_Word_tag), false); +#ifdef LISP_OBJECT_IS_STRUCT + comp.lisp_obj_i = gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.lisp_word_type, + "i"); + comp.lisp_obj_s = gcc_jit_context_new_struct_type (comp.ctxt, + NULL, + "Lisp_Object", + 1, + &comp.lisp_obj_i); + comp.lisp_obj_type = gcc_jit_struct_as_type (comp.lisp_obj_s); +#else + comp.lisp_obj_type = comp.lisp_word_type; +#endif comp.lisp_obj_ptr_type = gcc_jit_type_get_pointer (comp.lisp_obj_type); comp.one = gcc_jit_context_new_rvalue_from_int (comp.ctxt, diff --git a/src/lisp.h b/src/lisp.h index 893e278afe..9e4d53ccf1 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -299,12 +299,12 @@ error !; /* Lisp_Word is a scalar word suitable for holding a tagged pointer or integer. Usually it is a pointer to a deliberately-incomplete type - 'union Lisp_X'. However, it is EMACS_INT when Lisp_Objects and + 'struct Lisp_X'. However, it is EMACS_INT when Lisp_Objects and pointers differ in width. */ #define LISP_WORDS_ARE_POINTERS (EMACS_INT_MAX == INTPTR_MAX) #if LISP_WORDS_ARE_POINTERS -typedef union Lisp_X *Lisp_Word; +typedef struct Lisp_X *Lisp_Word; #else typedef EMACS_INT Lisp_Word; #endif @@ -573,6 +573,7 @@ enum Lisp_Fwd_Type #ifdef CHECK_LISP_OBJECT_TYPE typedef struct Lisp_Object { Lisp_Word i; } Lisp_Object; +# define LISP_OBJECT_IS_STRUCT # define LISP_INITIALLY(w) {w} # undef CHECK_LISP_OBJECT_TYPE enum CHECK_LISP_OBJECT_TYPE { CHECK_LISP_OBJECT_TYPE = true }; commit 5ff2cbdb04fe190c12b43a6c0f95a311da767872 Author: Nicolás Bértolo Date: Fri May 8 16:23:10 2020 -0300 * Remove a layer of indirection for access to pure storage. * src/comp.c: Taking the address of an array is the same as casting it to a pointer. Therefore, the C expression `(EMACS_INT **) &pure` is in fact adding a layer of indirection that is not necessary. The fix is to cast the `pure` array to a pointer and store that in a void pointer that is part of the compiled shared library. diff --git a/src/comp.c b/src/comp.c index 86a9721108..15dd0487c0 100644 --- a/src/comp.c +++ b/src/comp.c @@ -142,7 +142,7 @@ typedef struct { gcc_jit_type *thread_state_ptr_type; gcc_jit_rvalue *current_thread_ref; /* Other globals. */ - gcc_jit_rvalue *pure_ref; + gcc_jit_rvalue *pure_ptr; /* libgccjit has really limited support for casting therefore this union will be used for the scope. */ gcc_jit_type *cast_union_type; @@ -1320,8 +1320,7 @@ emit_PURE_P (gcc_jit_rvalue *ptr) GCC_JIT_BINARY_OP_MINUS, comp.uintptr_type, ptr, - gcc_jit_lvalue_as_rvalue ( - gcc_jit_rvalue_dereference (comp.pure_ref, NULL))), + comp.pure_ptr), gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.uintptr_type, PURESIZE)); @@ -2170,13 +2169,13 @@ emit_ctxt_code (void) gcc_jit_type_get_pointer (comp.thread_state_ptr_type), CURRENT_THREAD_RELOC_SYM)); - comp.pure_ref = + comp.pure_ptr = gcc_jit_lvalue_as_rvalue ( gcc_jit_context_new_global ( comp.ctxt, NULL, GCC_JIT_GLOBAL_EXPORTED, - gcc_jit_type_get_pointer (comp.void_ptr_type), + comp.void_ptr_type, PURE_RELOC_SYM)); gcc_jit_context_new_global ( @@ -3691,7 +3690,7 @@ load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u, bool loading_dump, { struct thread_state ***current_thread_reloc = dynlib_sym (handle, CURRENT_THREAD_RELOC_SYM); - EMACS_INT ***pure_reloc = dynlib_sym (handle, PURE_RELOC_SYM); + void **pure_reloc = dynlib_sym (handle, PURE_RELOC_SYM); Lisp_Object *data_relocs = dynlib_sym (handle, DATA_RELOC_SYM); Lisp_Object *data_imp_relocs = comp_u->data_imp_relocs; void **freloc_link_table = dynlib_sym (handle, FUNC_LINK_TABLE_SYM); @@ -3708,7 +3707,7 @@ load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u, bool loading_dump, xsignal1 (Qnative_lisp_file_inconsistent, comp_u->file); *current_thread_reloc = ¤t_thread; - *pure_reloc = (EMACS_INT **)&pure; + *pure_reloc = pure; /* Imported functions. */ *freloc_link_table = freloc.link_table; commit 72a96ed992bbc3ec446a974322dc8ba9dd94ce39 Author: Andrea Corallo Date: Wed May 20 20:24:41 2020 +0100 * src/comp.c (emit_setjmp): Aesthetic, respect 80 columns limit. diff --git a/src/comp.c b/src/comp.c index 3fa3361bbf..86a9721108 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1510,13 +1510,16 @@ emit_setjmp (gcc_jit_rvalue *buf) /* _setjmp (buf, __builtin_frame_address (0)) */ gcc_jit_rvalue *args[2]; - args[0] = gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.unsigned_type, 0); + args[0] = + gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.unsigned_type, 0); - args[1] = gcc_jit_context_new_call (comp.ctxt, - NULL, - gcc_jit_context_get_builtin_function (comp.ctxt, - "__builtin_frame_address"), - 1, args); + args[1] = + gcc_jit_context_new_call ( + comp.ctxt, + NULL, + gcc_jit_context_get_builtin_function (comp.ctxt, + "__builtin_frame_address"), + 1, args); args[0] = buf; return emit_call (intern_c_string (STR (SETJMP_NAME)), comp.int_type, 2, args, false); commit 05b08f26444213ce93aff668a80a81a820c73feb Author: Nicolás Bértolo Date: Fri May 8 15:56:09 2020 -0300 * Handle setjmp() taking two arguments in Windows. * src/comp.c: Add `define_setjmp_deps()` and `emit_setjmp()` which abstract over this difference in behavior between operating systems. WARNING: Not all cases are handled by this patch. The Mingw-64 setjmp.h header deals with many other combinations. I don't think it is a good idea to replicate the logic of that header inside emacs. (Maybe a few lines in the configure script could be added to handle this problem?) diff --git a/src/comp.c b/src/comp.c index 87b86ddba7..3fa3361bbf 100644 --- a/src/comp.c +++ b/src/comp.c @@ -22,6 +22,7 @@ along with GNU Emacs. If not, see . */ #ifdef HAVE_NATIVE_COMP +#include #include #include #include @@ -74,10 +75,15 @@ along with GNU Emacs. If not, see . */ gcc_jit_block *(name) = \ gcc_jit_function_new_block ((func), STR (name)) -#ifdef HAVE__SETJMP -#define SETJMP _setjmp +#ifndef WINDOWSNT +# ifdef HAVE__SETJMP +# define SETJMP _setjmp +# else +# define SETJMP setjmp +# endif #else -#define SETJMP setjmp +/* snippet from MINGW-64 setjmp.h */ +# define SETJMP _setjmp #endif #define SETJMP_NAME SETJMP @@ -1493,6 +1499,30 @@ emit_limple_call_ref (Lisp_Object insn, bool direct) direct); } +static gcc_jit_rvalue * +emit_setjmp (gcc_jit_rvalue *buf) +{ +#ifndef WINDOWSNT + gcc_jit_rvalue *args[] = {buf}; + return emit_call (intern_c_string (STR (SETJMP_NAME)), comp.int_type, 1, args, + false); +#else + /* _setjmp (buf, __builtin_frame_address (0)) */ + gcc_jit_rvalue *args[2]; + + args[0] = gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.unsigned_type, 0); + + args[1] = gcc_jit_context_new_call (comp.ctxt, + NULL, + gcc_jit_context_get_builtin_function (comp.ctxt, + "__builtin_frame_address"), + 1, args); + args[0] = buf; + return emit_call (intern_c_string (STR (SETJMP_NAME)), comp.int_type, 2, args, + false); +#endif +} + /* Register an handler for a non local exit. */ static void @@ -1519,8 +1549,7 @@ emit_limple_push_handler (gcc_jit_rvalue *handler, gcc_jit_rvalue *handler_type, NULL); gcc_jit_rvalue *res; - res = - emit_call (intern_c_string (STR (SETJMP_NAME)), comp.int_type, 1, args, false); + res = emit_setjmp (args[0]); emit_cond_jump (res, handler_bb, guarded_bb); } @@ -2079,8 +2108,14 @@ declare_runtime_imported_funcs (void) args[1] = comp.int_type; ADD_IMPORTED (push_handler, comp.handler_ptr_type, 2, args); +#ifndef WINDOWSNT args[0] = gcc_jit_type_get_pointer (gcc_jit_struct_as_type (comp.jmp_buf_s)); ADD_IMPORTED (SETJMP_NAME, comp.int_type, 1, args); +#else + args[0] = gcc_jit_type_get_pointer (gcc_jit_struct_as_type (comp.jmp_buf_s)); + args[1] = comp.void_ptr_type; + ADD_IMPORTED (SETJMP_NAME, comp.int_type, 2, args); +#endif ADD_IMPORTED (record_unwind_protect_excursion, comp.void_type, 0, NULL); @@ -2320,7 +2355,7 @@ define_jmp_buf (void) gcc_jit_context_new_array_type (comp.ctxt, NULL, comp.char_type, - sizeof (jmp_buf)), + sizeof (sys_jmp_buf)), "stuff"); comp.jmp_buf_s = gcc_jit_context_new_struct_type (comp.ctxt, commit 68fad7a8fc98d41284c4054dd7b53fbb0d990cba Author: Nicolás Bértolo Date: Fri May 8 16:02:58 2020 -0300 Do not block SIGIO in platforms that don't have it. * src/comp.c (comp--compile-ctxt-to-file): Add a preprocessor check to avoid blocking SIGIO in platforms that don't have it. Signed-off-by: Andrea Corallo diff --git a/src/comp.c b/src/comp.c index c9426d1990..87b86ddba7 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3364,7 +3364,9 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, sigemptyset (&blocked); sigaddset (&blocked, SIGALRM); sigaddset (&blocked, SIGINT); +#ifdef USABLE_SIGIO sigaddset (&blocked, SIGIO); +#endif pthread_sigmask (SIG_BLOCK, &blocked, &oldset); } emit_ctxt_code (); commit f5ba60defbef2445243b513416c2c2f2b5766cd6 Author: Andrea Corallo Date: Tue May 19 08:40:56 2020 +0100 * lisp/emacs-lisp/comp.el (comp-num-cpus): Fix definition. Introduced by 2aec16ab75. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index f94544877e..9fe614f9e9 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2296,7 +2296,7 @@ processes from `comp-async-compilations'" do (remhash file-name comp-async-compilations)) (hash-table-count comp-async-compilations)) -(defvar comp-num-cpus) +(defvar comp-num-cpus nil) (defun comp-effective-async-max-jobs () "Compute the effective number of async jobs." (if (zerop comp-async-jobs-number) commit 2aec16ab754aa803efd2e23a54485e34a56bf76c Author: Andrea Corallo Date: Mon May 18 20:51:46 2020 +0100 * Pacify with the byte-compiler * lisp/emacs-lisp/comp.el (comp-num-cpus): New special variable. (comp-effective-async-max-jobs): Make use of `comp-num-cpus'. (comp-call-optim-form-call): Remove unnecessary parameter. (comp-call-optim-func): Reflect `comp-call-optim-form-call' parameter removal. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index f23a0b29af..f94544877e 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1964,7 +1964,7 @@ Backward propagate array placement properties." ;; the full compilation unit. ;; For this reason this is triggered only at comp-speed == 3. -(defun comp-call-optim-form-call (callee args self) +(defun comp-call-optim-form-call (callee args) "" (cl-flet ((fill-args (args total) ;; Fill missing args to reach TOTAL @@ -2017,11 +2017,11 @@ Backward propagate array placement properties." do (pcase insn (`(set ,lval (callref funcall ,f . ,rest)) (when-let ((new-form (comp-call-optim-form-call - (comp-mvar-constant f) rest self))) + (comp-mvar-constant f) rest))) (setcar insn-cell `(set ,lval ,new-form)))) (`(callref funcall ,f . ,rest) (when-let ((new-form (comp-call-optim-form-call - (comp-mvar-constant f) rest self))) + (comp-mvar-constant f) rest))) (setcar insn-cell new-form))))))) (defun comp-call-optim (_) @@ -2296,17 +2296,17 @@ processes from `comp-async-compilations'" do (remhash file-name comp-async-compilations)) (hash-table-count comp-async-compilations)) -(let (num-cpus) - (defun comp-effective-async-max-jobs () - "Compute the effective number of async jobs." - (if (zerop comp-async-jobs-number) - (or num-cpus - (setf num-cpus - ;; Half of the CPUs or at least one. - ;; FIXME portable? - (max 1 (/ (string-to-number (shell-command-to-string "nproc")) - 2)))) - comp-async-jobs-number))) +(defvar comp-num-cpus) +(defun comp-effective-async-max-jobs () + "Compute the effective number of async jobs." + (if (zerop comp-async-jobs-number) + (or comp-num-cpus + (setf comp-num-cpus + ;; Half of the CPUs or at least one. + ;; FIXME portable? + (max 1 (/ (string-to-number (shell-command-to-string "nproc")) + 2)))) + comp-async-jobs-number)) (defun comp-run-async-workers () "Start compiling files from `comp-files-queue' asynchronously. commit 2ac619458520f1399088740e5e13751d362e55a0 Author: Andrea Corallo Date: Mon May 18 20:45:29 2020 +0100 * Add new customize `comp-async-env-modifier-form' (Bug#40838) * lisp/emacs-lisp/comp.el (comp-async-env-modifier-form): New customize. (comp-run-async-workers): Make use of `comp-async-env-modifier-form'. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index cd1e4dbd92..f23a0b29af 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -133,6 +133,12 @@ finishes compiling all input files." :type 'hook :group 'comp) +(defcustom comp-async-env-modifier-form nil + "Form to be evaluated by each asyncronous compilation worker +before compilation. Usable to modify the compiler environment." + :type 'list + :group 'comp) + (defvar comp-dry-run nil "When non nil run everything but the C back-end.") @@ -2324,6 +2330,7 @@ display a message." comp-debug ,comp-debug comp-verbose ,comp-verbose load-path ',load-path) + ,comp-async-env-modifier-form (message "Compiling %s..." ,source-file) (native-compile ,source-file ,(and load t)))) (source-file1 source-file) ;; Make the closure works :/ commit 6d850b50c536d558252017d4daea5d5718dcc8b2 Author: Andrea Corallo Date: Mon May 18 19:04:07 2020 +0100 * Make the Evil happy (Bug#41374) * lisp/emacs-lisp/comp.el (comp-never-optimize-functions): Blacklist all primitives advised by evil-mode from trampoline optimization. (comp-call-optim-form-call): Prevent trampoline optimization for recursive calls at speed 2 to respect elisp original semantic. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 662cfe2d4e..cd1e4dbd92 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -103,7 +103,10 @@ Skip if any is matching." macroexpand scroll-down scroll-up narrow-to-region widen rename-buffer make-indirect-buffer delete-file top-level abort-recursive-edit ;; For user convenience - yes-or-no-p) + yes-or-no-p + ;; Make the Evil happy :/ + read-key-sequence select-window set-window-buffer split-window-internal + use-global-map use-local-map) "Primitive functions for which we do not perform trampoline optimization. This is especially useful for primitives known to be advised or redefined when compilation is performed at `comp-speed' > 0." @@ -1983,10 +1986,9 @@ Backward propagate array placement properties." (fill-args args maxarg)))) `(,call-type ,callee ,@args))) ;; Intra compilation unit procedure call optimization. - ;; Attention speed 3 triggers that for non self calls too!! - ((or (eq callee self) - (and (>= comp-speed 3) - callee-in-unit)) + ;; Attention speed 3 triggers this for non self calls too!! + ((and (>= comp-speed 3) + callee-in-unit) (let* ((func-args (comp-func-args callee-in-unit)) (nargs (comp-nargs-p func-args)) (call-type (if nargs 'direct-callref 'direct-call)) commit cd4ef52c8673a76c6fcb0efd7d2c74778522038c Merge: 9e9421c7ee abec255c02 Author: Andrea Corallo Date: Sun May 17 22:49:02 2020 +0100 Merge remote-tracking branch 'savannah/master' into HEAD commit 9e9421c7eecd74c9f163253ab760044fca53f26b Author: Andrea Corallo Date: Sun May 17 08:48:26 2020 +0100 * Fix bug#41346 assertion triggered while loading dump * src/comp.c (load_comp_unit): While loading from dump lambda fixups are still to happen here. Verify relocation coherency only after 'top_level_run' execution. diff --git a/src/comp.c b/src/comp.c index dab102cccd..c9426d1990 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3720,10 +3720,9 @@ load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u, bool loading_dump, /* Make sure data_ephemeral_vec still exists after top_level_run has run. Guard against sibling call optimization (or any other). */ data_ephemeral_vec = data_ephemeral_vec; + eassert (check_comp_unit_relocs (comp_u)); } - eassert (check_comp_unit_relocs (comp_u)); - return; } commit d6f6353cfdbbea5501915675081265b4dc4591e3 Author: Andrea Corallo Date: Fri May 15 11:43:31 2020 +0100 * Do not refuse to compile if a dynamic lambda is encountered * lisp/emacs-lisp/comp.el (comp-lex-byte-func-p): New subst. (comp-intern-func-in-ctxt): Do not crash if we still encounter a non lexical scoped lambda. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 38c89ec263..662cfe2d4e 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -487,6 +487,11 @@ VERBOSITY is a number between 0 and 3." ;;; spill-lap pass specific code. +(defsubst comp-lex-byte-func-p (f) + "Return t if F is a lexical scoped byte compiled function." + (and (byte-code-function-p f) + (fixnump (aref f 0)))) + (defun comp-c-func-name (name prefix) "Given NAME return a name suitable for the native code. Put PREFIX in front of it." @@ -590,28 +595,31 @@ Put PREFIX in front of it." byte-func)) return form)) (name (when top-l-form - (byte-to-native-func-def-name top-l-form))) - (c-name (comp-c-func-name (or name "anonymous-lambda") "F")) - (func (make-comp-func :name name - :byte-func byte-func - :doc (documentation byte-func) - :int-spec (interactive-form byte-func) - :c-name c-name - :args (comp-decrypt-arg-list (aref byte-func 0) - name) - :lap lap - :frame-size (comp-byte-frame-size byte-func)))) - ;; Store the c-name to have it retrivable from - ;; `comp-ctxt-top-level-forms'. - (when top-l-form - (setf (byte-to-native-func-def-c-name top-l-form) c-name)) - (unless name - (puthash byte-func func (comp-ctxt-byte-func-to-func-h comp-ctxt))) - ;; Create the default array. - (puthash 0 (comp-func-frame-size func) (comp-func-array-h func)) - (comp-add-func-to-ctxt func) - (comp-log (format "Function %s:\n" name) 1) - (comp-log lap 1)))) + (byte-to-native-func-def-name top-l-form)))) + ;; Do not refuse to compile if a dynamic byte-compiled lambda + ;; leaks here (advice). + (when (or name (comp-lex-byte-func-p byte-func)) + (let* ((c-name (comp-c-func-name (or name "anonymous-lambda") "F")) + (func (make-comp-func :name name + :byte-func byte-func + :doc (documentation byte-func) + :int-spec (interactive-form byte-func) + :c-name c-name + :args (comp-decrypt-arg-list (aref byte-func 0) + name) + :lap lap + :frame-size (comp-byte-frame-size byte-func)))) + ;; Store the c-name to have it retrivable from + ;; `comp-ctxt-top-level-forms'. + (when top-l-form + (setf (byte-to-native-func-def-c-name top-l-form) c-name)) + (unless name + (puthash byte-func func (comp-ctxt-byte-func-to-func-h comp-ctxt))) + ;; Create the default array. + (puthash 0 (comp-func-frame-size func) (comp-func-array-h func)) + (comp-add-func-to-ctxt func) + (comp-log (format "Function %s:\n" name) 1) + (comp-log lap 1)))))) (cl-defgeneric comp-spill-lap-function ((filename string)) "Byte compile FILENAME spilling data from the byte compiler." commit 9a64585c126200d0f4b65fd45f6380244fe1d26c Author: Andrea Corallo Date: Thu May 14 09:11:55 2020 +0100 * Allow for logging async compilation command line * lisp/emacs-lisp/comp.el (comp-run-async-workers): When non zero verbose log async compilation command line invocation. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 7de8e0177c..38c89ec263 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2317,6 +2317,9 @@ display a message." (message "Compiling %s..." ,source-file) (native-compile ,source-file ,(and load t)))) (source-file1 source-file) ;; Make the closure works :/ + (_ (progn + (comp-log "\n") + (comp-log (prin1-to-string expr)))) (load1 load) (process (make-process :name (concat "Compiling: " source-file) commit ff9e40e9fefacfda9cce38d8884694b1c5207b1c Author: Andrea Corallo Date: Wed May 13 22:43:48 2020 +0100 * Add check_comp_unit_relocs * src/comp.c (check_comp_unit_relocs): Add function to verify relocation coherency. (load_comp_unit): Call it. diff --git a/src/comp.c b/src/comp.c index d1f8fe23f0..dab102cccd 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3572,6 +3572,37 @@ load_static_obj (struct Lisp_Native_Comp_Unit *comp_u, const char *name) return Fread (make_string (res->data, res->len)); } +/* Return false when something is wrong or true otherwise. */ + +static bool +check_comp_unit_relocs (struct Lisp_Native_Comp_Unit *comp_u) +{ + dynlib_handle_ptr handle = comp_u->handle; + Lisp_Object *data_relocs = dynlib_sym (handle, DATA_RELOC_SYM); + Lisp_Object *data_imp_relocs = dynlib_sym (handle, DATA_RELOC_IMPURE_SYM); + + EMACS_INT d_vec_len = XFIXNUM (Flength (comp_u->data_vec)); + for (EMACS_INT i = 0; i < d_vec_len; i++) + if (!EQ (data_relocs[i], AREF (comp_u->data_vec, i))) + return false; + + d_vec_len = XFIXNUM (Flength (comp_u->data_impure_vec)); + for (EMACS_INT i = 0; i < d_vec_len; i++) + { + Lisp_Object x = data_imp_relocs[i]; + if (EQ (x, Qlambda_fixup)) + return false; + else if (SUBR_NATIVE_COMPILEDP (x)) + { + if (NILP (Fgethash (x, comp_u->lambda_gc_guard, Qnil))) + return false; + } + else if (!EQ (data_imp_relocs[i], AREF (comp_u->data_impure_vec, i))) + return false; + } + return true; +} + void load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u, bool loading_dump, bool late_load) @@ -3691,6 +3722,8 @@ load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u, bool loading_dump, data_ephemeral_vec = data_ephemeral_vec; } + eassert (check_comp_unit_relocs (comp_u)); + return; } commit e351a12216519d3ed09892752ce0b137f6672986 Author: Andrea Corallo Date: Wed May 13 08:52:47 2020 +0100 Sanity check on lambdas fixups * src/pdumper.c (dump_do_dump_relocation): While fixing up lambda relocation verify placeholder coherency. * src/comp.c (syms_of_comp): Define symbol 'lambda-fixup'. * lisp/emacs-lisp/comp.el (comp-finalize-container): Leave a lambda-fixup as placeholder in the relocation as a sanity check. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index d546218940..7de8e0177c 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2158,7 +2158,7 @@ These are substituted with a normal 'set' op." ;; from the corresponding m-var. collect (if (gethash obj (comp-ctxt-byte-func-to-func-h comp-ctxt)) - nil + 'lambda-fixup obj)))) (defun comp-finalize-relocs () diff --git a/src/comp.c b/src/comp.c index 3a362fd095..d1f8fe23f0 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3891,6 +3891,7 @@ syms_of_comp (void) DEFSYM (Qfixnum, "fixnum"); DEFSYM (Qscratch, "scratch"); DEFSYM (Qlate, "late"); + DEFSYM (Qlambda_fixup, "lambda-fixup"); /* To be signaled by the compiler. */ DEFSYM (Qnative_compiler_error, "native-compiler-error"); diff --git a/src/pdumper.c b/src/pdumper.c index a1b71e87ac..a6d12b6ea0 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -5342,11 +5342,14 @@ dump_do_dump_relocation (const uintptr_t dump_base, if (!NILP (lambda_data_idx)) { /* This is an anonymous lambda. - We must fixup data_vec so the lambda can be referenced + We must fixup d_reloc_imp so the lambda can be referenced by code. */ Lisp_Object tem; XSETSUBR (tem, subr); - comp_u->data_imp_relocs[XFIXNUM (lambda_data_idx)] = tem; + Lisp_Object *fixup = + &(comp_u->data_imp_relocs[XFIXNUM (lambda_data_idx)]); + eassert (EQ (*fixup, Qlambda_fixup)); + *fixup = tem; Fputhash (tem, Qnil, comp_u->lambda_gc_guard); } break; commit 2b064c780cdcb4a7bb832e11d4a166954c485ac5 Author: Andrea Corallo Date: Mon May 11 19:21:01 2020 +0100 * Fix speed 2 bootstrap (comp-call-optim-func): Do nothing if the function name is unknown. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 94ffc2d177..d546218940 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1994,6 +1994,7 @@ Backward propagate array placement properties." (cl-loop with self = (comp-func-name comp-func) for b being each hash-value of (comp-func-blocks comp-func) + when self ;; FIXME add proper anonymous lambda support. do (cl-loop for insn-cell on (comp-block-insns b) for insn = (car insn-cell) commit e5b24b85a25000499186fc3a48f39eed586d5a3f Author: Andrea Corallo Date: Mon May 11 17:29:43 2020 +0100 * Native compiler test update * test/src/comp-tests.el (comp-tests-lambda-return): Add a test verifying that the returned lambda is actually native compiled. diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index ce98227162..c07c92a106 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -277,7 +277,9 @@ Check that the resulting binaries do not differ." (should (string= (comp-tests-buff0-f) "foo"))) (ert-deftest comp-tests-lambda-return () - (should (= (funcall (comp-tests-lambda-return-f) 3) 4))) + (let ((f (comp-tests-lambda-return-f))) + (should (subr-native-elisp-p f)) + (should (= (funcall f 3) 4)))) (ert-deftest comp-tests-recursive () (should (= (comp-tests-fib-f 10) 55))) commit 27b80ae94c677a41f0ca67afe2c36f9e77380390 Author: Andrea Corallo Date: Sun May 10 16:04:48 2020 +0100 * Better Vcomp_sym_subr_c_name_h test function + doc * src/comp.c (syms_of_comp): 'Vcomp_sym_subr_c_name_h' need only 'eq' as test + fix doc for 'comp-sym-subr-c-name-h'. diff --git a/src/comp.c b/src/comp.c index 5ace2d2805..3a362fd095 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3960,8 +3960,8 @@ syms_of_comp (void) doc: /* List of all defined subrs. */); DEFVAR_LISP ("comp-sym-subr-c-name-h", Vcomp_sym_subr_c_name_h, doc: /* Hash table symbol-function -> function-c-name. For - internal use during */); - Vcomp_sym_subr_c_name_h = CALLN (Fmake_hash_table); + internal use during dump reload */); + Vcomp_sym_subr_c_name_h = CALLN (Fmake_hash_table, QCtest, Qeq); DEFVAR_LISP ("comp-abi-hash", Vcomp_abi_hash, doc: /* String signing the ABI exposed to .eln files. */); Vcomp_abi_hash = Qnil; commit 44b0ce6e38f06df10b60ffdd9d9ade4b7e229088 Author: Andrea Corallo Date: Sat May 2 17:29:11 2020 +0100 Add anonymous lambdas reload mechanism * src/pdumper.c (dump_do_dump_relocation): Initialize 'lambda_gc_guard' while resurrecting. (dump_do_dump_relocation): Revive lambdas and fixup them. * src/comp.h (struct Lisp_Native_Comp_Unit): Define new 'lambda_gc_guard' 'lambda_c_name_idx_h' 'data_imp_relocs' 'loaded_once' fields. * src/comp.c (load_comp_unit): Use compilaiton unit 'loaded_once' field. (make_subr, Fcomp__register_lambda): New functions. (Fcomp__register_subr): Make use of 'make_subr'. (Fnative_elisp_load): Indent. (Fnative_elisp_load): Initialize 'lambda_gc_guard' 'lambda_c_name_idx_h' fields. (syms_of_comp): Add Scomp__register_lambda. * lisp/emacs-lisp/comp.el (comp-ctxt): Change 'byte-func-to-func-h' hash key test. (comp-ctxt): Add 'lambda-fixups-h' slot. (comp-emit-lambda-for-top-level): New function. (comp-finalize-relocs): Never emit lambdas in pure space. (comp-finalize-relocs): Fixup relocation indexes. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 3bcfdc9420..94ffc2d177 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -230,9 +230,11 @@ Can be one of: 'd-default', 'd-impure' or 'd-ephemeral'. See `comp-ctxt'.") (sym-to-c-name-h (make-hash-table :test #'eq) :type hash-table :documentation "symbol-function -> c-name. This is only for optimizing intra CU calls at speed 3.") - (byte-func-to-func-h (make-hash-table :test #'eq) :type hash-table + (byte-func-to-func-h (make-hash-table :test #'equal) :type hash-table :documentation "byte-function -> comp-func. Needed to replace immediate byte-compiled lambdas with the compiled reference.") + (lambda-fixups-h (make-hash-table :test #'equal) :type hash-table + :documentation "Hash table byte-func -> mvar to fixup.") (function-docs (make-hash-table :test #'eql) :type (or hash-table vector) :documentation "Documentation index -> documentation") (d-default (make-comp-data-container) :type comp-data-container @@ -1276,6 +1278,36 @@ the annotation emission." (make-comp-mvar :constant form)) (make-comp-mvar :constant t)))))) +(defun comp-emit-lambda-for-top-level (func) + "Emit the creation of subrs for lambda FUNC. +These are stored in the reloc data array." + (let ((args (comp-func-args func))) + (let ((comp-curr-allocation-class 'd-impure)) + (comp-add-const-to-relocs (comp-func-byte-func func))) + (comp-emit + (comp-call 'comp--register-lambda + ;; mvar to be fixed-up when containers are + ;; finalized. + (or (gethash (comp-func-byte-func func) + (comp-ctxt-lambda-fixups-h comp-ctxt)) + (puthash (comp-func-byte-func func) + (make-comp-mvar :constant nil) + (comp-ctxt-lambda-fixups-h comp-ctxt))) + (make-comp-mvar :constant (comp-args-base-min args)) + (make-comp-mvar :constant (if (comp-args-p args) + (comp-args-max args) + 'many)) + (make-comp-mvar :constant (comp-func-c-name func)) + (make-comp-mvar + :constant (let* ((h (comp-ctxt-function-docs comp-ctxt)) + (i (hash-table-count h))) + (puthash i (comp-func-doc func) h) + i)) + (make-comp-mvar :constant (comp-func-int-spec func)) + ;; This is the compilation unit it-self passed as + ;; parameter. + (make-comp-mvar :slot 0))))) + (defun comp-limplify-top-level (for-late-load) "Create a limple function to modify the global environment at load. When FOR-LATE-LOAD is non nil the emitted function modifies only @@ -2143,6 +2175,12 @@ Update all insn accordingly." (d-impure-idx (comp-data-container-idx d-impure)) (d-ephemeral (comp-ctxt-d-ephemeral comp-ctxt)) (d-ephemeral-idx (comp-data-container-idx d-ephemeral))) + ;; We never want compiled lambdas ending up in pure space. A copy must + ;; be already present in impure (see `comp-emit-lambda-for-top-level'). + (cl-loop for obj being each hash-keys of d-default-idx + when (gethash obj (comp-ctxt-lambda-fixups-h comp-ctxt)) + do (cl-assert (gethash obj d-impure-idx)) + (remhash obj d-default-idx)) ;; Remove entries in d-impure already present in d-default. (cl-loop for obj being each hash-keys of d-impure-idx when (gethash obj d-default-idx) @@ -2162,7 +2200,20 @@ Update all insn accordingly." for doc = (gethash idx h) do (setf (aref v idx) doc) finally - do (setf (comp-ctxt-function-docs comp-ctxt) v)))) + do (setf (comp-ctxt-function-docs comp-ctxt) v)) + ;; And now we conclude with the following: We need to pass to + ;; `comp--register-lambda' the index in the impure relocation + ;; array to store revived lambdas, but given we know it only now + ;; we fix it up as last. + (cl-loop for f being each hash-keys of (comp-ctxt-lambda-fixups-h comp-ctxt) + using (hash-value mvar) + with reverse-h = (make-hash-table) ;; Make sure idx is unique. + for idx = (gethash f d-impure-idx) + do + (cl-assert (null (gethash idx reverse-h))) + (cl-assert (fixnump idx)) + (setf (comp-mvar-constant mvar) idx) + (puthash idx t reverse-h)))) (defun comp-compile-ctxt-to-file (name) "Compile as native code the current context naming it NAME. diff --git a/src/comp.c b/src/comp.c index 947da9a8e2..5ace2d2805 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3583,15 +3583,15 @@ load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u, bool loading_dump, Lisp_Object *saved_cu = dynlib_sym (handle, COMP_UNIT_SYM); if (!saved_cu) xsignal1 (Qnative_lisp_file_inconsistent, comp_u->file); - bool reloading_cu = !NILP (*saved_cu); + comp_u->loaded_once = !NILP (*saved_cu); Lisp_Object *data_eph_relocs = dynlib_sym (handle, DATA_RELOC_EPHEMERAL_SYM); /* While resurrecting from an image dump loading more than once the same compilation unit does not make any sense. */ - eassert (!(loading_dump && reloading_cu)); + eassert (!(loading_dump && comp_u->loaded_once)); - if (reloading_cu) + if (comp_u->loaded_once) /* 'dlopen' returns the same handle when trying to load two times the same shared. In this case touching 'd_reloc' etc leads to fails in case a frame with a reference to it in a live reg is @@ -3612,13 +3612,17 @@ load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u, bool loading_dump, = dynlib_sym (handle, late_load ? "late_top_level_run" : "top_level_run"); - if (!reloading_cu) + /* Always set data_imp_relocs pointer in the compilation unit (in can be + used in 'dump_do_dump_relocation'). */ + comp_u->data_imp_relocs = dynlib_sym (handle, DATA_RELOC_IMPURE_SYM); + + if (!comp_u->loaded_once) { struct thread_state ***current_thread_reloc = dynlib_sym (handle, CURRENT_THREAD_RELOC_SYM); EMACS_INT ***pure_reloc = dynlib_sym (handle, PURE_RELOC_SYM); Lisp_Object *data_relocs = dynlib_sym (handle, DATA_RELOC_SYM); - Lisp_Object *data_imp_relocs = dynlib_sym (handle, DATA_RELOC_IMPURE_SYM); + Lisp_Object *data_imp_relocs = comp_u->data_imp_relocs; void **freloc_link_table = dynlib_sym (handle, FUNC_LINK_TABLE_SYM); if (!(current_thread_reloc @@ -3704,15 +3708,13 @@ native_function_doc (Lisp_Object function) return AREF (cu->data_fdoc_v, XSUBR (function)->doc); } -DEFUN ("comp--register-subr", Fcomp__register_subr, Scomp__register_subr, - 7, 7, 0, - doc: /* This gets called by top_level_run during load phase to register - each exported subr. */) - (Lisp_Object name, Lisp_Object minarg, Lisp_Object maxarg, - Lisp_Object c_name, Lisp_Object doc_idx, Lisp_Object intspec, - Lisp_Object comp_u) +static Lisp_Object +make_subr (Lisp_Object symbol_name, Lisp_Object minarg, Lisp_Object maxarg, + Lisp_Object c_name, Lisp_Object doc_idx, Lisp_Object intspec, + Lisp_Object comp_u) { - dynlib_handle_ptr handle = XNATIVE_COMP_UNIT (comp_u)->handle; + struct Lisp_Native_Comp_Unit *cu = XNATIVE_COMP_UNIT (comp_u); + dynlib_handle_ptr handle = cu->handle; if (!handle) xsignal0 (Qwrong_register_subr_call); @@ -3727,18 +3729,63 @@ DEFUN ("comp--register-subr", Fcomp__register_subr, Scomp__register_subr, x->s.function.a0 = func; x->s.min_args = XFIXNUM (minarg); x->s.max_args = FIXNUMP (maxarg) ? XFIXNUM (maxarg) : MANY; - x->s.symbol_name = xstrdup (SSDATA (Fsymbol_name (name))); + x->s.symbol_name = xstrdup (SSDATA (symbol_name)); x->s.native_intspec = intspec; x->s.doc = XFIXNUM (doc_idx); x->s.native_comp_u[0] = comp_u; Lisp_Object tem; XSETSUBR (tem, &x->s); - set_symbol_function (name, tem); - Fputhash (name, c_name, Vcomp_sym_subr_c_name_h); + return tem; +} + +DEFUN ("comp--register-lambda", Fcomp__register_lambda, Scomp__register_lambda, + 7, 7, 0, + doc: /* This gets called by top_level_run during load phase to register + anonymous lambdas. */) + (Lisp_Object reloc_idx, Lisp_Object minarg, Lisp_Object maxarg, + Lisp_Object c_name, Lisp_Object doc_idx, Lisp_Object intspec, + Lisp_Object comp_u) +{ + struct Lisp_Native_Comp_Unit *cu = XNATIVE_COMP_UNIT (comp_u); + if (cu->loaded_once) + return Qnil; + + Lisp_Object tem = + make_subr (c_name, minarg, maxarg, c_name, doc_idx, intspec, comp_u); + + /* We must protect it against GC because the function is not + reachable through symbols. */ + Fputhash (tem, Qt, cu->lambda_gc_guard); + /* This is for fixing up the value in d_reloc while resurrecting + from dump. See 'dump_do_dump_relocation'. */ + Fputhash (c_name, reloc_idx, cu->lambda_c_name_idx_h); + /* The key is not really important as long is the same as + symbol_name so use c_name. */ + Fputhash (Fintern (c_name, Qnil), c_name, Vcomp_sym_subr_c_name_h); + /* Do the real relocation fixup. */ + cu->data_imp_relocs[XFIXNUM (reloc_idx)] = tem; + + return tem; +} + +DEFUN ("comp--register-subr", Fcomp__register_subr, Scomp__register_subr, + 7, 7, 0, + doc: /* This gets called by top_level_run during load phase to register + each exported subr. */) + (Lisp_Object name, Lisp_Object minarg, Lisp_Object maxarg, + Lisp_Object c_name, Lisp_Object doc_idx, Lisp_Object intspec, + Lisp_Object comp_u) +{ + Lisp_Object tem = + make_subr (SYMBOL_NAME (name), minarg, maxarg, c_name, doc_idx, intspec, + comp_u); + + set_symbol_function (name, tem); LOADHIST_ATTACH (Fcons (Qdefun, name)); + Fputhash (name, c_name, Vcomp_sym_subr_c_name_h); - return Qnil; + return tem; } DEFUN ("comp--late-register-subr", Fcomp__late_register_subr, @@ -3759,8 +3806,8 @@ DEFUN ("comp--late-register-subr", Fcomp__late_register_subr, /* Load related routines. */ DEFUN ("native-elisp-load", Fnative_elisp_load, Snative_elisp_load, 1, 2, 0, doc: /* Load native elisp code FILE. - LATE_LOAD has to be non nil when loading for deferred - compilation. */) + LATE_LOAD has to be non nil when loading for deferred + compilation. */) (Lisp_Object file, Lisp_Object late_load) { CHECK_STRING (file); @@ -3773,6 +3820,8 @@ DEFUN ("native-elisp-load", Fnative_elisp_load, Snative_elisp_load, 1, 2, 0, xsignal2 (Qnative_lisp_load_failed, file, build_string (dynlib_error ())); comp_u->file = file; comp_u->data_vec = Qnil; + comp_u->lambda_gc_guard = CALLN (Fmake_hash_table, QCtest, Qeq); + comp_u->lambda_c_name_idx_h = CALLN (Fmake_hash_table, QCtest, Qequal); load_comp_unit (comp_u, false, !NILP (late_load)); return Qt; @@ -3886,6 +3935,7 @@ syms_of_comp (void) defsubr (&Scomp__init_ctxt); defsubr (&Scomp__release_ctxt); defsubr (&Scomp__compile_ctxt_to_file); + defsubr (&Scomp__register_lambda); defsubr (&Scomp__register_subr); defsubr (&Scomp__late_register_subr); defsubr (&Snative_elisp_load); diff --git a/src/comp.h b/src/comp.h index cbdcaccd5f..b03a805514 100644 --- a/src/comp.h +++ b/src/comp.h @@ -37,13 +37,21 @@ struct Lisp_Native_Comp_Unit /* Original eln file loaded. */ Lisp_Object file; Lisp_Object optimize_qualities; - /* Hash doc-idx -> function documentaiton. */ + /* Guard anonymous lambdas against Garbage Collection and make them + dumpable. */ + Lisp_Object lambda_gc_guard; + /* Hash c_name -> d_reloc_imp index. */ + Lisp_Object lambda_c_name_idx_h; + /* Hash doc-idx -> function documentaiton. */ Lisp_Object data_fdoc_v; /* Analogous to the constant vector but per compilation unit. */ Lisp_Object data_vec; - /* Same but for data that cannot be moved to pure space. - Must be the last lisp object here. */ + /* 'data_impure_vec' must be last (see allocate_native_comp_unit). + Same as data_vec but for data that cannot be moved to pure space. */ Lisp_Object data_impure_vec; + /* STUFFS WE DO NOT DUMP!! */ + Lisp_Object *data_imp_relocs; + bool loaded_once; dynlib_handle_ptr handle; }; diff --git a/src/pdumper.c b/src/pdumper.c index f837dfc38d..a1b71e87ac 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -5297,7 +5297,7 @@ dump_do_dump_relocation (const uintptr_t dump_base, static enum { UNKNOWN, LOCAL_BUILD, INSTALLED } installation_state; struct Lisp_Native_Comp_Unit *comp_u = dump_ptr (dump_base, reloc_offset); - + comp_u->lambda_gc_guard = CALLN (Fmake_hash_table, QCtest, Qeq); if (!CONSP (comp_u->file)) error ("Trying to load incoherent dumped .eln"); @@ -5320,6 +5320,10 @@ dump_do_dump_relocation (const uintptr_t dump_base, } case RELOC_NATIVE_SUBR: { + /* When resurrecting from a dump given non all the original + native compiled subrs may be still around we can't rely on + a 'top_level_run' mechanism, we revive them one-by-one + here. */ struct Lisp_Subr *subr = dump_ptr (dump_base, reloc_offset); Lisp_Object name = intern (subr->symbol_name); struct Lisp_Native_Comp_Unit *comp_u = @@ -5333,6 +5337,18 @@ dump_do_dump_relocation (const uintptr_t dump_base, if (!func) error ("can't find function in compilation unit"); subr->function.a0 = func; + Lisp_Object lambda_data_idx = + Fgethash (c_name, comp_u->lambda_c_name_idx_h, Qnil); + if (!NILP (lambda_data_idx)) + { + /* This is an anonymous lambda. + We must fixup data_vec so the lambda can be referenced + by code. */ + Lisp_Object tem; + XSETSUBR (tem, subr); + comp_u->data_imp_relocs[XFIXNUM (lambda_data_idx)] = tem; + Fputhash (tem, Qnil, comp_u->lambda_gc_guard); + } break; } #endif commit 49f0331f53fb9eaa2039538a983eb7b6dbcd206f Author: Andrea Corallo Date: Sun May 3 20:55:23 2020 +0100 * Render all immediates as comments at comp-debug > 2 * src/comp.c (emit_mvar_rval): No reason to emit only fixnums. diff --git a/src/comp.c b/src/comp.c index e18bace668..947da9a8e2 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1338,11 +1338,23 @@ emit_mvar_rval (Lisp_Object mvar) if (!NILP (const_vld)) { + if (COMP_DEBUG > 1) + { + Lisp_Object func = + Fgethash (constant, + CALL1I (comp-ctxt-byte-func-to-func-h, Vcomp_ctxt), + Qnil); + + emit_comment ( + SSDATA ( + Fprin1_to_string ( + NILP (func) ? constant : CALL1I (comp-func-c-name, func), + Qnil))); + } if (FIXNUMP (constant)) { /* We can still emit directly objects that are self-contained in a word (read fixnums). */ - emit_comment (SSDATA (Fprin1_to_string (constant, Qnil))); gcc_jit_rvalue *word; #ifdef WIDE_EMACS_INT word = emit_rvalue_from_long_long (constant); commit 6eb14daccf0e3045fbbc858b4d3aeb3006f14e60 Author: Andrea Corallo Date: Sun May 3 20:34:03 2020 +0100 * Dump log and intemediate GCC IRs only at comp-debug 3 * src/comp.c (Fcomp__init_ctxt): Increase threshold for dumping really everything to 'comp-debug' 3. diff --git a/src/comp.c b/src/comp.c index c88c9f3f48..e18bace668 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3233,7 +3233,7 @@ DEFUN ("comp--init-ctxt", Fcomp__init_ctxt, Scomp__init_ctxt, GCC_JIT_BOOL_OPTION_DEBUGINFO, 1); } - if (COMP_DEBUG > 1) + if (COMP_DEBUG > 2) { logfile = fopen ("libgccjit.log", "w"); gcc_jit_context_set_logfile (comp.ctxt, commit 2ee2fb5a86a8933b1105a1dc5b597ebb8ce57e40 Author: Andrea Corallo Date: Sun May 3 20:26:35 2020 +0100 * Prune now unnecessary byte-code objects * lisp/emacs-lisp/comp.el (comp-finalize-container): Prune byte-code that was lambdas. (comp-compile-ctxt-to-file): Remove fixme. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 705225d82f..3bcfdc9420 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2117,7 +2117,16 @@ These are substituted with a normal 'set' op." for obj each hash-keys of h for i from 0 do (puthash obj i h) - collect obj))) + ;; Prune byte-code objects coming from lambdas. + ;; These are not anymore necessary as they will be + ;; replaced at load time by native-elisp-subrs. + ;; Note: we leave the objects in the idx hash table + ;; to still be able to retrieve the correct index + ;; from the corresponding m-var. + collect (if (gethash obj + (comp-ctxt-byte-func-to-func-h comp-ctxt)) + nil + obj)))) (defun comp-finalize-relocs () "Finalize data containers for each relocation class. @@ -2159,7 +2168,6 @@ Update all insn accordingly." "Compile as native code the current context naming it NAME. Prepare every function for final compilation and drive the C back-end." (let ((dir (file-name-directory name))) - ;; FIXME: Strip bytecompiled functions here. (comp-finalize-relocs) (unless (file-exists-p dir) ;; In case it's created in the meanwhile. commit c12831a6b6fd445950300d33c95747ac923e1ebf Author: Andrea Corallo Date: Sun May 3 15:11:07 2020 +0100 * Rework comp-spill-lap-function * lisp/emacs-lisp/comp.el (comp-spill-lap-function): Move code from to comp-intern-func-in-ctxt. (comp-intern-func-in-ctxt): New function, this guard in case byte-to-native-lambda-byte-func is nil. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 3977580fc8..705225d82f 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -576,6 +576,41 @@ Put PREFIX in front of it." (puthash 0 (comp-func-frame-size func) (comp-func-array-h func)) (comp-add-func-to-ctxt func)))) +(defun comp-intern-func-in-ctxt (_ obj) + "Given OBJ of type `byte-to-native-lambda' create a function in `comp-ctxt'." + (when-let ((byte-func (byte-to-native-lambda-byte-func obj))) + (let* ((byte-func (byte-to-native-lambda-byte-func obj)) + (lap (byte-to-native-lambda-lap obj)) + (top-l-form (cl-loop + for form in (comp-ctxt-top-level-forms comp-ctxt) + when (and (byte-to-native-func-def-p form) + (eq (byte-to-native-func-def-byte-func form) + byte-func)) + return form)) + (name (when top-l-form + (byte-to-native-func-def-name top-l-form))) + (c-name (comp-c-func-name (or name "anonymous-lambda") "F")) + (func (make-comp-func :name name + :byte-func byte-func + :doc (documentation byte-func) + :int-spec (interactive-form byte-func) + :c-name c-name + :args (comp-decrypt-arg-list (aref byte-func 0) + name) + :lap lap + :frame-size (comp-byte-frame-size byte-func)))) + ;; Store the c-name to have it retrivable from + ;; `comp-ctxt-top-level-forms'. + (when top-l-form + (setf (byte-to-native-func-def-c-name top-l-form) c-name)) + (unless name + (puthash byte-func func (comp-ctxt-byte-func-to-func-h comp-ctxt))) + ;; Create the default array. + (puthash 0 (comp-func-frame-size func) (comp-func-array-h func)) + (comp-add-func-to-ctxt func) + (comp-log (format "Function %s:\n" name) 1) + (comp-log lap 1)))) + (cl-defgeneric comp-spill-lap-function ((filename string)) "Byte compile FILENAME spilling data from the byte compiler." (byte-compile-file filename) @@ -583,41 +618,7 @@ Put PREFIX in front of it." (signal 'native-compiler-error-empty-byte filename)) (setf (comp-ctxt-top-level-forms comp-ctxt) (reverse byte-to-native-top-level-forms)) - (cl-loop - for x being each hash-value of byte-to-native-lambdas-h - for byte-func = (byte-to-native-lambda-byte-func x) - for lap = (byte-to-native-lambda-lap x) - for top-l-form = (cl-loop - for form in (comp-ctxt-top-level-forms comp-ctxt) - when (and (byte-to-native-func-def-p form) - (eq (byte-to-native-func-def-byte-func form) - byte-func)) - return form) - for name = (when top-l-form - (byte-to-native-func-def-name top-l-form)) - for c-name = (comp-c-func-name (or name "anonymous-lambda") - "F") - for func = (make-comp-func :name name - :byte-func byte-func - :doc (documentation byte-func) - :int-spec (interactive-form byte-func) - :c-name c-name - :args (comp-decrypt-arg-list (aref byte-func 0) - name) - :lap lap - :frame-size (comp-byte-frame-size byte-func)) - ;; Store the c-name to have it retrivable from - ;; comp-ctxt-top-level-forms. - when top-l-form - do (setf (byte-to-native-func-def-c-name top-l-form) c-name) - unless name - do (puthash byte-func func (comp-ctxt-byte-func-to-func-h comp-ctxt)) - do - ;; Create the default array. - (puthash 0 (comp-func-frame-size func) (comp-func-array-h func)) - (comp-add-func-to-ctxt func) - (comp-log (format "Function %s:\n" name) 1) - (comp-log lap 1))) + (maphash #'comp-intern-func-in-ctxt byte-to-native-lambdas-h)) (defun comp-spill-lap (input) "Byte compile and spill the LAP representation for INPUT. commit 392a6f9bab5eb2a872380cfaff3a7ab6f809dac6 Author: Andrea Corallo Date: Sat May 2 20:33:42 2020 +0100 * Split emit_const_lisp_obj logic * src/comp.c (emit_lisp_obj_reloc_lval): New function. (emit_const_lisp_obj): Rename into 'emit_lisp_obj_rval' and strip logic for 'emit_lisp_obj_reloc_lval'. (emit_NILP, emit_CHECK_CONS, emit_mvar_rval, emit_set_internal) (define_CAR_CDR, define_bool_to_lisp_obj): Update for 'emit_const_lisp_obj' being renamed. diff --git a/src/comp.c b/src/comp.c index 45d293db85..c88c9f3f48 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1099,8 +1099,21 @@ emit_make_fixnum (gcc_jit_rvalue *obj) : emit_make_fixnum_MSB_TAG (obj); } +static gcc_jit_lvalue * +emit_lisp_obj_reloc_lval (Lisp_Object obj) +{ + emit_comment (format_string ("l-value for lisp obj: %s", + SSDATA (Fprin1_to_string (obj, Qnil)))); + + imm_reloc_t reloc = obj_to_reloc (obj); + return gcc_jit_context_new_array_access (comp.ctxt, + NULL, + reloc.array, + reloc.idx); +} + static gcc_jit_rvalue * -emit_const_lisp_obj (Lisp_Object obj) +emit_lisp_obj_rval (Lisp_Object obj) { emit_comment (format_string ("const lisp obj: %s", SSDATA (Fprin1_to_string (obj, Qnil)))); @@ -1119,20 +1132,14 @@ emit_const_lisp_obj (Lisp_Object obj) return emit_coerce (comp.lisp_obj_type, n); } - imm_reloc_t reloc = obj_to_reloc (obj); - return - gcc_jit_lvalue_as_rvalue ( - gcc_jit_context_new_array_access (comp.ctxt, - NULL, - reloc.array, - reloc.idx)); + return gcc_jit_lvalue_as_rvalue (emit_lisp_obj_reloc_lval (obj)); } static gcc_jit_rvalue * emit_NILP (gcc_jit_rvalue *x) { emit_comment ("NILP"); - return emit_EQ (x, emit_const_lisp_obj (Qnil)); + return emit_EQ (x, emit_lisp_obj_rval (Qnil)); } static gcc_jit_rvalue * @@ -1235,7 +1242,7 @@ emit_CHECK_CONS (gcc_jit_rvalue *x) gcc_jit_rvalue *args[] = { emit_CONSP (x), - emit_const_lisp_obj (Qconsp), + emit_lisp_obj_rval (Qconsp), x }; gcc_jit_block_add_eval ( @@ -1348,7 +1355,7 @@ emit_mvar_rval (Lisp_Object mvar) return emit_coerce (comp.lisp_obj_type, word); } /* Other const objects are fetched from the reloc array. */ - return emit_const_lisp_obj (constant); + return emit_lisp_obj_rval (constant); } return gcc_jit_lvalue_as_rvalue (emit_mvar_lval (mvar)); @@ -1383,7 +1390,7 @@ emit_set_internal (Lisp_Object args) gcc_jit_rvalue *gcc_args[4]; FOR_EACH_TAIL (args) gcc_args[i++] = emit_mvar_rval (XCAR (args)); - gcc_args[2] = emit_const_lisp_obj (Qnil); + gcc_args[2] = emit_lisp_obj_rval (Qnil); gcc_args[3] = gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.int_type, SET_INTERNAL_SET); @@ -2626,11 +2633,11 @@ define_CAR_CDR (void) comp.block = is_nil_b; gcc_jit_block_end_with_return (comp.block, NULL, - emit_const_lisp_obj (Qnil)); + emit_lisp_obj_rval (Qnil)); comp.block = not_nil_b; gcc_jit_rvalue *wrong_type_args[] = - { emit_const_lisp_obj (Qlistp), c }; + { emit_lisp_obj_rval (Qlistp), c }; gcc_jit_block_add_eval (comp.block, NULL, @@ -2639,7 +2646,7 @@ define_CAR_CDR (void) false)); gcc_jit_block_end_with_return (comp.block, NULL, - emit_const_lisp_obj (Qnil)); + emit_lisp_obj_rval (Qnil)); } comp.car = func[0]; comp.cdr = func[1]; @@ -3000,12 +3007,12 @@ define_bool_to_lisp_obj (void) comp.block = ret_t_block; gcc_jit_block_end_with_return (ret_t_block, NULL, - emit_const_lisp_obj (Qt)); + emit_lisp_obj_rval (Qt)); comp.block = ret_nil_block; gcc_jit_block_end_with_return (ret_nil_block, NULL, - emit_const_lisp_obj (Qnil)); + emit_lisp_obj_rval (Qnil)); } /* Declare a function being compiled and add it to comp.exported_funcs_h. */ commit acf7e129ea13b4650983135c8c92447b230a0c99 Author: Andrea Corallo Date: Sat May 2 20:14:13 2020 +0100 * Rename emit_mvar_access -> emit_mvar_lval * src/comp.c (emit_mvar_access): Rename into 'emit_mvar_lval'. (emit_mvar_rval, emit_frame_assignment): Update for 'emit_mvar_access' rename. diff --git a/src/comp.c b/src/comp.c index 4ba7e400bc..45d293db85 100644 --- a/src/comp.c +++ b/src/comp.c @@ -373,7 +373,7 @@ declare_block (Lisp_Object block_name) } static gcc_jit_lvalue * -emit_mvar_access (Lisp_Object mvar) +emit_mvar_lval (Lisp_Object mvar) { Lisp_Object mvar_slot = CALL1I (comp-mvar-slot, mvar); @@ -1351,7 +1351,7 @@ emit_mvar_rval (Lisp_Object mvar) return emit_const_lisp_obj (constant); } - return gcc_jit_lvalue_as_rvalue (emit_mvar_access (mvar)); + return gcc_jit_lvalue_as_rvalue (emit_mvar_lval (mvar)); } static void @@ -1361,7 +1361,7 @@ emit_frame_assignment (Lisp_Object dst_mvar, gcc_jit_rvalue *val) gcc_jit_block_add_assignment ( comp.block, NULL, - emit_mvar_access (dst_mvar), + emit_mvar_lval (dst_mvar), val); } commit 5bf685f17cd9e8875cb117a086a75c32d832f4f7 Author: Andrea Corallo Date: Sat May 2 20:12:41 2020 +0100 * Rename emit_mvar_val -> emit_mvar_rval * src/comp.c (emit_mvar_val): Rename into 'emit_mvar_rval'. (emit_set_internal, emit_simple_limple_call, emit_limple_insn) (emit_call_with_type_hint, emit_call2_with_type_hint) (emit_consp, emit_numperp, emit_integerp): Update for 'emit_mvar_val' rename. diff --git a/src/comp.c b/src/comp.c index c85181f626..4ba7e400bc 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1324,7 +1324,7 @@ emit_PURE_P (gcc_jit_rvalue *ptr) from frame. */ static gcc_jit_rvalue * -emit_mvar_val (Lisp_Object mvar) +emit_mvar_rval (Lisp_Object mvar) { Lisp_Object const_vld = CALL1I (comp-mvar-const-vld, mvar); Lisp_Object constant = CALL1I (comp-mvar-constant, mvar); @@ -1382,7 +1382,7 @@ emit_set_internal (Lisp_Object args) int i = 0; gcc_jit_rvalue *gcc_args[4]; FOR_EACH_TAIL (args) - gcc_args[i++] = emit_mvar_val (XCAR (args)); + gcc_args[i++] = emit_mvar_rval (XCAR (args)); gcc_args[2] = emit_const_lisp_obj (Qnil); gcc_args[3] = gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.int_type, @@ -1403,7 +1403,7 @@ emit_simple_limple_call (Lisp_Object args, gcc_jit_type *ret_type, bool direct) ptrdiff_t nargs = list_length (args); gcc_jit_rvalue **gcc_args = SAFE_ALLOCA (nargs * sizeof (*gcc_args)); FOR_EACH_TAIL (args) - gcc_args[i++] = emit_mvar_val (XCAR (args)); + gcc_args[i++] = emit_mvar_rval (XCAR (args)); SAFE_FREE (); return emit_call (callee, ret_type, nargs, gcc_args, direct); @@ -1531,8 +1531,8 @@ emit_limple_insn (Lisp_Object insn) else if (EQ (op, Qcond_jump)) { /* Conditional branch. */ - gcc_jit_rvalue *a = emit_mvar_val (arg[0]); - gcc_jit_rvalue *b = emit_mvar_val (arg[1]); + gcc_jit_rvalue *a = emit_mvar_rval (arg[0]); + gcc_jit_rvalue *b = emit_mvar_rval (arg[1]); gcc_jit_block *target1 = retrive_block (arg[2]); gcc_jit_block *target2 = retrive_block (arg[3]); @@ -1569,7 +1569,7 @@ emit_limple_insn (Lisp_Object insn) /* (push-handler condition-case #s(comp-mvar 0 3 t (arith-error) cons nil) 1 bb_2 bb_1) */ int h_num UNINIT; Lisp_Object handler_spec = arg[0]; - gcc_jit_rvalue *handler = emit_mvar_val (arg[1]); + gcc_jit_rvalue *handler = emit_mvar_rval (arg[1]); if (EQ (handler_spec, Qcatcher)) h_num = CATCHER; else if (EQ (handler_spec, Qcondition_case)) @@ -1665,7 +1665,7 @@ emit_limple_insn (Lisp_Object insn) Lisp_Object arg1 = arg[1]; if (EQ (Ftype_of (arg1), Qcomp_mvar)) - res = emit_mvar_val (arg1); + res = emit_mvar_rval (arg1); else if (EQ (FIRST (arg1), Qcall)) res = emit_limple_call (XCDR (arg1)); else if (EQ (FIRST (arg1), Qcallref)) @@ -1778,7 +1778,7 @@ emit_limple_insn (Lisp_Object insn) { gcc_jit_block_end_with_return (comp.block, NULL, - emit_mvar_val (arg[0])); + emit_mvar_rval (arg[0])); } else { @@ -1799,7 +1799,7 @@ emit_call_with_type_hint (gcc_jit_function *func, Lisp_Object insn, { bool type_hint = EQ (CALL1I (comp-mvar-type, SECOND (insn)), type); gcc_jit_rvalue *args[] = - { emit_mvar_val (SECOND (insn)), + { emit_mvar_rval (SECOND (insn)), gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.bool_type, type_hint) }; @@ -1814,8 +1814,8 @@ emit_call2_with_type_hint (gcc_jit_function *func, Lisp_Object insn, { bool type_hint = EQ (CALL1I (comp-mvar-type, SECOND (insn)), type); gcc_jit_rvalue *args[] = - { emit_mvar_val (SECOND (insn)), - emit_mvar_val (THIRD (insn)), + { emit_mvar_rval (SECOND (insn)), + emit_mvar_rval (THIRD (insn)), gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.bool_type, type_hint) }; @@ -1845,7 +1845,7 @@ emit_negate (Lisp_Object insn) static gcc_jit_rvalue * emit_consp (Lisp_Object insn) { - gcc_jit_rvalue *x = emit_mvar_val (SECOND (insn)); + gcc_jit_rvalue *x = emit_mvar_rval (SECOND (insn)); gcc_jit_rvalue *res = emit_coerce (comp.bool_type, emit_CONSP (x)); return gcc_jit_context_new_call (comp.ctxt, @@ -1881,7 +1881,7 @@ emit_setcdr (Lisp_Object insn) static gcc_jit_rvalue * emit_numperp (Lisp_Object insn) { - gcc_jit_rvalue *x = emit_mvar_val (SECOND (insn)); + gcc_jit_rvalue *x = emit_mvar_rval (SECOND (insn)); gcc_jit_rvalue *res = emit_NUMBERP (x); return gcc_jit_context_new_call (comp.ctxt, NULL, comp.bool_to_lisp_obj, 1, &res); @@ -1890,7 +1890,7 @@ emit_numperp (Lisp_Object insn) static gcc_jit_rvalue * emit_integerp (Lisp_Object insn) { - gcc_jit_rvalue *x = emit_mvar_val (SECOND (insn)); + gcc_jit_rvalue *x = emit_mvar_rval (SECOND (insn)); gcc_jit_rvalue *res = emit_INTEGERP (x); return gcc_jit_context_new_call (comp.ctxt, NULL, comp.bool_to_lisp_obj, 1, &res); commit 3ab6a756671f95213d5bf083cf9852e0c61af1db Author: Andrea Corallo Date: Mon May 11 21:17:29 2020 +0100 * Indentation fix * src/comp.c (Fcomp__init_ctxt, Fcomp__release_ctxt) (Fcomp__compile_ctxt_to_file, Fcomp__register_subr): Indentation fix. diff --git a/src/comp.c b/src/comp.c index e3a80adfa9..c85181f626 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3182,7 +3182,7 @@ compile_function (Lisp_Object func) DEFUN ("comp--init-ctxt", Fcomp__init_ctxt, Scomp__init_ctxt, 0, 0, 0, doc: /* Initialize the native compiler context. Return t on success. */) - (void) + (void) { if (comp.ctxt) { @@ -3306,7 +3306,7 @@ DEFUN ("comp--init-ctxt", Fcomp__init_ctxt, Scomp__init_ctxt, DEFUN ("comp--release-ctxt", Fcomp__release_ctxt, Scomp__release_ctxt, 0, 0, 0, doc: /* Release the native compiler context. */) - (void) + (void) { if (comp.ctxt) gcc_jit_context_release (comp.ctxt); @@ -3322,7 +3322,7 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, Scomp__compile_ctxt_to_file, 1, 1, 0, doc: /* Compile as native code the current context to file. */) - (Lisp_Object base_name) + (Lisp_Object base_name) { CHECK_STRING (base_name); @@ -3689,9 +3689,9 @@ DEFUN ("comp--register-subr", Fcomp__register_subr, Scomp__register_subr, 7, 7, 0, doc: /* This gets called by top_level_run during load phase to register each exported subr. */) - (Lisp_Object name, Lisp_Object minarg, Lisp_Object maxarg, - Lisp_Object c_name, Lisp_Object doc_idx, Lisp_Object intspec, - Lisp_Object comp_u) + (Lisp_Object name, Lisp_Object minarg, Lisp_Object maxarg, + Lisp_Object c_name, Lisp_Object doc_idx, Lisp_Object intspec, + Lisp_Object comp_u) { dynlib_handle_ptr handle = XNATIVE_COMP_UNIT (comp_u)->handle; if (!handle) @@ -3726,9 +3726,9 @@ DEFUN ("comp--late-register-subr", Fcomp__late_register_subr, Scomp__late_register_subr, 7, 7, 0, doc: /* This gets called by late_top_level_run during load phase to register each exported subr. */) - (Lisp_Object name, Lisp_Object minarg, Lisp_Object maxarg, - Lisp_Object c_name, Lisp_Object doc, Lisp_Object intspec, - Lisp_Object comp_u) + (Lisp_Object name, Lisp_Object minarg, Lisp_Object maxarg, + Lisp_Object c_name, Lisp_Object doc, Lisp_Object intspec, + Lisp_Object comp_u) { if (!NILP (Fequal (Fsymbol_function (name), Fgethash (name, Vcomp_deferred_pending_h, Qnil)))) commit a335f7eeacd5381af1d8ef38a4c2b8e832ca96fa Author: Andrea Corallo Date: Fri May 1 17:32:39 2020 +0100 Update spill LAP machinery and compile anonymous lambdas * lisp/emacs-lisp/comp.el (comp-spill-lap-function): Make use of byte-to-native-lambdas-h and update for 'byte-to-native-func-def'. (comp-spill-lap-function): Rework logic to retrive LAP using 'byte-to-native-lambdas-h'. (comp-emit-for-top-level): Update for 'byte-to-native-function'. * lisp/emacs-lisp/bytecomp.el: Add commentary on new spill LAP mechanism. (byte-to-native-lambda, byte-to-native-func-def): New structures. (byte-to-native-top-level): Indent. (byte-to-native-lambdas-h): Update doc. (byte-compile-lapcode): Add a 'byte-to-native-lambda' instance into byte-to-native-lambdas-h instead of just LAP. (byte-compile-file-form-defmumble): Store into 'byte-to-native-func-def' only the byte compiled function, the LAP will be retrived through 'byte-to-native-lambdas-h'. (byte-compile-lambda): Return the byte compiled function. diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index c0662a6d28..f33c30e574 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -562,13 +562,31 @@ Each element is (INDEX . VALUE)") (defvar byte-compile-depth 0 "Current depth of execution stack.") (defvar byte-compile-maxdepth 0 "Maximum depth of execution stack.") -;; These are use by comp.el to spill data out of here -(cl-defstruct byte-to-native-function - "Named or anonymous function defined a top level." - name c-name data lap) +;; The following is used by comp.el to spill data out of here. +;; +;; Spilling is done in 3 places: +;; +;; - `byte-compile-lapcode' to obtain the map bytecode -> LAP for any +;; code assembled. +;; +;; - `byte-compile-lambda' to obtain arglist doc and interactive spec +;; af any lambda compiled (including anonymous). +;; +;; - `byte-compile-file-form-defmumble' to obtain the list of +;; top-level forms as they would be outputted in the .elc file. +;; + +(cl-defstruct byte-to-native-lambda + byte-func lap) + +;; Top level forms: +(cl-defstruct byte-to-native-func-def + "Named function defined at top-level." + name c-name byte-func) (cl-defstruct byte-to-native-top-level - "All other top level forms." - form) + "All other top-level forms." + form) + (defvar byte-native-compiling nil "Non nil while native compiling.") (defvar byte-native-for-bootstrap nil @@ -577,8 +595,8 @@ Each element is (INDEX . VALUE)") ;; Because the make target is the later this has to be produced as ;; last to be resilient against build interruptions. ) -(defvar byte-to-native-lap-h nil - "Hash byte-code -> LAP.") +(defvar byte-to-native-lambdas-h nil + "Hash byte-code -> byte-to-native-lambda.") (defvar byte-to-native-top-level-forms nil "List of top level forms.") (defvar byte-to-native-output-file nil @@ -978,8 +996,9 @@ CONST2 may be evaluated multiple times." hash-table)) (let ((bytecode (apply 'unibyte-string (nreverse bytes)))) (when byte-native-compiling - ;; Spill LAP for the native compiler here - (puthash bytecode lap byte-to-native-lap-h)) + ;; Spill LAP for the native compiler here. + (puthash bytecode (make-byte-to-native-lambda :lap lap) + byte-to-native-lambdas-h)) bytecode))) @@ -2689,10 +2708,8 @@ not to take responsibility for the actual compilation of the code." (push (if macro (make-byte-to-native-top-level :form `(defalias ',name '(macro . ,code) nil)) - (make-byte-to-native-function :name name - :data code - :lap (gethash (aref code 1) - byte-to-native-lap-h))) + (make-byte-to-native-func-def :name name + :byte-func code)) byte-to-native-top-level-forms)) ;; Output the form by hand, that's much simpler than having ;; b-c-output-file-form analyze the defalias. @@ -2950,23 +2967,30 @@ for symbols generated by the byte compiler itself." reserved-csts))) ;; Build the actual byte-coded function. (cl-assert (eq 'byte-code (car-safe compiled))) - (apply #'make-byte-code - (if lexical-binding - (byte-compile-make-args-desc arglist) - arglist) - (append - ;; byte-string, constants-vector, stack depth - (cdr compiled) - ;; optionally, the doc string. - (cond ((and lexical-binding arglist) - ;; byte-compile-make-args-desc lost the args's names, - ;; so preserve them in the docstring. - (list (help-add-fundoc-usage doc arglist))) - ((or doc int) - (list doc))) - ;; optionally, the interactive spec. - (if int - (list (nth 1 int)))))))) + (let ((out + (apply #'make-byte-code + (if lexical-binding + (byte-compile-make-args-desc arglist) + arglist) + (append + ;; byte-string, constants-vector, stack depth + (cdr compiled) + ;; optionally, the doc string. + (cond ((and lexical-binding arglist) + ;; byte-compile-make-args-desc lost the args's names, + ;; so preserve them in the docstring. + (list (help-add-fundoc-usage doc arglist))) + ((or doc int) + (list doc))) + ;; optionally, the interactive spec. + (if int + (list (nth 1 int))))))) + (when byte-native-compiling + (setf (byte-to-native-lambda-byte-func + (gethash (cadr compiled) + byte-to-native-lambdas-h)) + out)) + out)))) (defvar byte-compile-reserved-constants 0) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index c2a95feec1..3977580fc8 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -230,6 +230,9 @@ Can be one of: 'd-default', 'd-impure' or 'd-ephemeral'. See `comp-ctxt'.") (sym-to-c-name-h (make-hash-table :test #'eq) :type hash-table :documentation "symbol-function -> c-name. This is only for optimizing intra CU calls at speed 3.") + (byte-func-to-func-h (make-hash-table :test #'eq) :type hash-table + :documentation "byte-function -> comp-func. +Needed to replace immediate byte-compiled lambdas with the compiled reference.") (function-docs (make-hash-table :test #'eql) :type (or hash-table vector) :documentation "Documentation index -> documentation") (d-default (make-comp-data-container) :type comp-data-container @@ -311,7 +314,7 @@ Is in use to help the SSA rename pass.")) (cl-defstruct (comp-func (:copier nil)) "LIMPLE representation of a function." (name nil :type symbol - :documentation "Function symbol name.") + :documentation "Function symbol name. Nil indicates anonymous.") (c-name nil :type string :documentation "The function name in the native world.") (byte-func nil @@ -554,8 +557,9 @@ Put PREFIX in front of it." "can't native compile an already bytecompiled function")) (setf (comp-func-byte-func func) (byte-compile (comp-func-name func))) - (let ((lap (gethash (aref (comp-func-byte-func func) 1) - byte-to-native-lap-h))) + (let ((lap (byte-to-native-lambda-lap + (gethash (aref (comp-func-byte-func func) 1) + byte-to-native-lambdas-h)))) (cl-assert lap) (comp-log lap 2) (let ((arg-list (aref (comp-func-byte-func func) 0))) @@ -566,7 +570,7 @@ Put PREFIX in front of it." (comp-func-frame-size func) (comp-byte-frame-size (comp-func-byte-func func)))) (setf (comp-ctxt-top-level-forms comp-ctxt) - (list (make-byte-to-native-function :name function-name + (list (make-byte-to-native-func-def :name function-name :c-name c-name))) ;; Create the default array. (puthash 0 (comp-func-frame-size func) (comp-func-array-h func)) @@ -580,38 +584,47 @@ Put PREFIX in front of it." (setf (comp-ctxt-top-level-forms comp-ctxt) (reverse byte-to-native-top-level-forms)) (cl-loop - ;; All non anonymous functions. - for f in (cl-loop for x in (comp-ctxt-top-level-forms comp-ctxt) - when (and (byte-to-native-function-p x) - (byte-to-native-function-name x)) - collect x) - for name = (byte-to-native-function-name f) - for c-name = (comp-c-func-name name "F") - for data = (byte-to-native-function-data f) + for x being each hash-value of byte-to-native-lambdas-h + for byte-func = (byte-to-native-lambda-byte-func x) + for lap = (byte-to-native-lambda-lap x) + for top-l-form = (cl-loop + for form in (comp-ctxt-top-level-forms comp-ctxt) + when (and (byte-to-native-func-def-p form) + (eq (byte-to-native-func-def-byte-func form) + byte-func)) + return form) + for name = (when top-l-form + (byte-to-native-func-def-name top-l-form)) + for c-name = (comp-c-func-name (or name "anonymous-lambda") + "F") for func = (make-comp-func :name name - :byte-func data - :doc (documentation data) - :int-spec (interactive-form data) + :byte-func byte-func + :doc (documentation byte-func) + :int-spec (interactive-form byte-func) :c-name c-name - :args (comp-decrypt-arg-list (aref data 0) name) - :lap (byte-to-native-function-lap f) - :frame-size (comp-byte-frame-size data)) - do + :args (comp-decrypt-arg-list (aref byte-func 0) + name) + :lap lap + :frame-size (comp-byte-frame-size byte-func)) ;; Store the c-name to have it retrivable from ;; comp-ctxt-top-level-forms. - (setf (byte-to-native-function-c-name f) c-name) + when top-l-form + do (setf (byte-to-native-func-def-c-name top-l-form) c-name) + unless name + do (puthash byte-func func (comp-ctxt-byte-func-to-func-h comp-ctxt)) + do ;; Create the default array. (puthash 0 (comp-func-frame-size func) (comp-func-array-h func)) (comp-add-func-to-ctxt func) (comp-log (format "Function %s:\n" name) 1) - (comp-log (byte-to-native-function-lap f) 1))) + (comp-log lap 1))) (defun comp-spill-lap (input) "Byte compile and spill the LAP representation for INPUT. If INPUT is a symbol this is the function-name to be compiled. If INPUT is a string this is the file path to be compiled." (let ((byte-native-compiling t) - (byte-to-native-lap-h (make-hash-table :test #'eq)) + (byte-to-native-lambdas-h (make-hash-table :test #'eq)) (byte-to-native-top-level-forms ())) (comp-spill-lap-function input))) @@ -1225,10 +1238,10 @@ the annotation emission." (cl-defgeneric comp-emit-for-top-level (form for-late-load) "Emit the limple code for top level FORM.") -(cl-defmethod comp-emit-for-top-level ((form byte-to-native-function) +(cl-defmethod comp-emit-for-top-level ((form byte-to-native-func-def) for-late-load) - (let* ((name (byte-to-native-function-name form)) - (c-name (byte-to-native-function-c-name form)) + (let* ((name (byte-to-native-func-def-name form)) + (c-name (byte-to-native-func-def-c-name form)) (f (gethash c-name (comp-ctxt-funcs-h comp-ctxt))) (args (comp-func-args f))) (cl-assert (and name f)) @@ -1293,6 +1306,9 @@ into the C code forwarding the compilation unit." "Top level")) ;; Assign the compilation unit incoming as parameter to the slot frame 0. (comp-emit `(set-par-to-local ,(comp-slot-n 0) 0)) + (maphash (lambda (_ func) + (comp-emit-lambda-for-top-level func)) + (comp-ctxt-byte-func-to-func-h comp-ctxt)) (mapc (lambda (x) (comp-emit-for-top-level x for-late-load)) (comp-ctxt-top-level-forms comp-ctxt)) (comp-emit `(return ,(make-comp-mvar :constant t))) @@ -2142,6 +2158,7 @@ Update all insn accordingly." "Compile as native code the current context naming it NAME. Prepare every function for final compilation and drive the C back-end." (let ((dir (file-name-directory name))) + ;; FIXME: Strip bytecompiled functions here. (comp-finalize-relocs) (unless (file-exists-p dir) ;; In case it's created in the meanwhile. commit 28df049b8d43586d5a91a7b3e1d9e05131572afc Author: Andrea Corallo Date: Wed May 13 19:48:57 2020 +0100 * test/src/comp-tests.el (comp-tests-bootstrap): Fix test. diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 4768e1a1ac..ce98227162 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -44,21 +44,20 @@ Check that the resulting binaries do not differ." "../../lisp/emacs-lisp/comp.el")) (comp1-src (make-temp-file "stage1-" nil ".el")) (comp2-src (make-temp-file "stage2-" nil ".el")) - (comp1 (concat comp1-src "n")) - (comp2 (concat comp2-src "n")) ;; Can't use debug symbols. (comp-debug 0)) (copy-file comp-src comp1-src t) (copy-file comp-src comp2-src t) (load (concat comp-src "c") nil nil t t) - (should (null (subr-native-elisp-p (symbol-function #'native-compile)))) + (should-not (subr-native-elisp-p (symbol-function #'native-compile))) (message "Compiling stage1...") - (load (native-compile comp1-src) nil nil t t) - (should (subr-native-elisp-p (symbol-function 'native-compile))) - (message "Compiling stage2...") - (native-compile comp2-src) - (message "Comparing %s %s" comp1 comp2) - (should (= (call-process "cmp" nil nil nil comp1 comp2) 0)))) + (let ((comp1-eln (native-compile comp1-src))) + (load comp1-eln nil nil t t) + (should (subr-native-elisp-p (symbol-function 'native-compile))) + (message "Compiling stage2...") + (let ((comp2-eln (native-compile comp2-src))) + (message "Comparing %s %s" comp1-eln comp2-eln) + (should (= (call-process "cmp" nil nil nil comp1-eln comp2-eln) 0)))))) (ert-deftest comp-tests-provide () "Testing top level provide." commit 3bcb79fdcd450391a3669a7f97287230629255b2 Merge: 9bc0a7c408 a4671733b7 Author: Andrea Corallo Date: Thu May 14 07:14:23 2020 +0100 Merge remote-tracking branch 'savannah/master' into HEAD commit 9bc0a7c408237f7dc6846544e647da7b08988ab9 Author: Andrea Corallo Date: Sun May 10 08:48:50 2020 +0100 * Fix `comp-deferred-compilation-black-list' effectiveness * lisp/emacs-lisp/comp.el (native-compile-async): Fix logic for 'comp-deferred-compilation-black-list' effectiveness. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index e6a43b85af..c2a95feec1 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2376,12 +2376,13 @@ LOAD can be nil t or 'late." queued with LOAD %" file load (cdr entry)) ;; Make sure we are not already compiling `file' (bug#40838). - (unless (and (gethash file comp-async-compilations) - ;; Exclude some file from deferred compilation if - ;; `comp-deferred-compilation-black-list' says so. - (or (not (eq load 'late)) - (cl-notany (lambda (re) (string-match re file)) - comp-deferred-compilation-black-list))) + (unless (or (gethash file comp-async-compilations) + ;; Also exclude files from deferred compilation if + ;; any of the regexps in + ;; `comp-deferred-compilation-black-list' matches. + (and (eq load 'late) + (cl-some (lambda (re) (string-match re file)) + comp-deferred-compilation-black-list))) (let ((out-dir (comp-output-directory file)) (out-filename (comp-output-filename file))) (if (or (file-writable-p out-filename) commit 49def706f361754a3e374c105328a3eec892beff Author: Andrea Corallo Date: Sun May 10 08:58:53 2020 +0100 * src/comp.c (load_comp_unit): Style fix. diff --git a/src/comp.c b/src/comp.c index 768172b3aa..e3a80adfa9 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3564,7 +3564,7 @@ load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u, bool loading_dump, Lisp_Object *saved_cu = dynlib_sym (handle, COMP_UNIT_SYM); if (!saved_cu) xsignal1 (Qnative_lisp_file_inconsistent, comp_u->file); - bool reloading_cu = !NILP (*saved_cu) ? true : false; + bool reloading_cu = !NILP (*saved_cu); Lisp_Object *data_eph_relocs = dynlib_sym (handle, DATA_RELOC_EPHEMERAL_SYM); commit bc50c0c57eca22cb290465ae5df93d48326eeb05 Merge: bd8be64ce3 9d8fc3a598 Author: Andrea Corallo Date: Sat May 9 20:04:41 2020 +0100 Merge remote-tracking branch 'savannah/master' into HEAD commit bd8be64ce3f314c152d009f5bf88bcfadf6daef7 Author: Andrea Corallo Date: Sat May 9 19:07:35 2020 +0100 * Fix --enable-check-lisp-object-type GNU/Linux X86_64 build * src/comp.c (emit_mvar_val): Fix missing use of XLP macro. (load_comp_unit): Fix missing use of NILP macro. diff --git a/src/comp.c b/src/comp.c index d021be479b..768172b3aa 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1343,7 +1343,7 @@ emit_mvar_val (Lisp_Object mvar) word = gcc_jit_context_new_rvalue_from_ptr (comp.ctxt, comp.void_ptr_type, - constant); + XLP (constant)); #endif return emit_coerce (comp.lisp_obj_type, word); } @@ -3564,7 +3564,7 @@ load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u, bool loading_dump, Lisp_Object *saved_cu = dynlib_sym (handle, COMP_UNIT_SYM); if (!saved_cu) xsignal1 (Qnative_lisp_file_inconsistent, comp_u->file); - bool reloading_cu = *saved_cu ? true : false; + bool reloading_cu = !NILP (*saved_cu) ? true : false; Lisp_Object *data_eph_relocs = dynlib_sym (handle, DATA_RELOC_EPHEMERAL_SYM); commit c6eb2760766b402fb620a733d100adfd320e4df5 Merge: 40f655e050 ae3c510696 Author: Andrea Corallo Date: Sat May 9 14:06:55 2020 +0100 Merge remote-tracking branch 'savannah/master' into HEAD commit 40f655e0505d954e507ead5f5bda7dc7113adc06 Author: Andrea Corallo Date: Sat May 9 13:52:30 2020 +0100 * Add 'comp-deferred-compilation-black-list' customize * lisp/emacs-lisp/comp.el (comp-deferred-compilation-black-list): New customize. (native-compile-async): Make use of 'comp-deferred-compilation-black-list'. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 616410375e..e6a43b85af 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -84,6 +84,13 @@ This intended for debugging the compiler itself. :type 'boolean :group 'comp) +(defcustom comp-deferred-compilation-black-list + '() + "List of regexps to exclude files from deferred native compilation. +Skip if any is matching." + :type 'list + :group 'comp) + (defcustom comp-bootstrap-black-list '("^leim/") "List of regexps to exclude files from native compilation during bootstrap. @@ -2369,7 +2376,12 @@ LOAD can be nil t or 'late." queued with LOAD %" file load (cdr entry)) ;; Make sure we are not already compiling `file' (bug#40838). - (unless (gethash file comp-async-compilations) + (unless (and (gethash file comp-async-compilations) + ;; Exclude some file from deferred compilation if + ;; `comp-deferred-compilation-black-list' says so. + (or (not (eq load 'late)) + (cl-notany (lambda (re) (string-match re file)) + comp-deferred-compilation-black-list))) (let ((out-dir (comp-output-directory file)) (out-filename (comp-output-filename file))) (if (or (file-writable-p out-filename) commit 92dc81f85e1b91db04487ccf1b52c0cd3328dfee Merge: cf105f6044 de5f59219a Author: Andrea Corallo Date: Thu May 7 10:24:30 2020 +0100 Merge remote-tracking branch 'savannah/master' into HEAD commit cf105f604413d270c956adf375217960e3945e2a Author: Andrea Corallo Date: Thu May 7 08:10:50 2020 +0100 * Fix bug#41112 * lisp/emacs-lisp/comp.el (comp-jump-table-optimizable): New function. (comp-emit-switch): Make use of 'comp-jump-table-optimizable'. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 60b41f95bd..616410375e 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -850,44 +850,56 @@ Return value is the fall through block name." (`(TAG ,label . ,_) (puthash label addr (comp-limplify-label-to-addr comp-pass)))))) +(defun comp-jump-table-optimizable (jmp-table) + "Return t if JMP-TABLE can be optimized out." + (cl-loop + with labels = (cl-loop for target-label being each hash-value of jmp-table + collect target-label) + with x = (car labels) + for l in (cdr-safe labels) + unless (= l x) + return nil + finally return t)) + (defun comp-emit-switch (var last-insn) "Emit a limple for a lap jump table given VAR and LAST-INSN." ;; FIXME this not efficient for big jump tables. We should have a second ;; strategy for this case. (pcase last-insn (`(setimm ,_ ,jmp-table) - (cl-loop - for test being each hash-keys of jmp-table - using (hash-value target-label) - with len = (hash-table-count jmp-table) - with test-func = (hash-table-test jmp-table) - for n from 1 - for last = (= n len) - for m-test = (make-comp-mvar :constant test) - for target-name = (comp-block-name (comp-bb-maybe-add (comp-label-to-addr target-label) - (comp-sp))) - for ff-bb = (if last - (comp-bb-maybe-add (1+ (comp-limplify-pc comp-pass)) - (comp-sp)) - (make--comp-block nil - (comp-sp) - (comp-new-block-sym))) - for ff-bb-name = (comp-block-name ff-bb) - if (eq test-func 'eq) - do (comp-emit (list 'cond-jump var m-test ff-bb-name target-name)) - else + (unless (comp-jump-table-optimizable jmp-table) + (cl-loop + for test being each hash-keys of jmp-table + using (hash-value target-label) + with len = (hash-table-count jmp-table) + with test-func = (hash-table-test jmp-table) + for n from 1 + for last = (= n len) + for m-test = (make-comp-mvar :constant test) + for target-name = (comp-block-name (comp-bb-maybe-add (comp-label-to-addr target-label) + (comp-sp))) + for ff-bb = (if last + (comp-bb-maybe-add (1+ (comp-limplify-pc comp-pass)) + (comp-sp)) + (make--comp-block nil + (comp-sp) + (comp-new-block-sym))) + for ff-bb-name = (comp-block-name ff-bb) + if (eq test-func 'eq) + do (comp-emit (list 'cond-jump var m-test ff-bb-name target-name)) + else ;; Store the result of the comparison into the scratch slot before ;; emitting the conditional jump. - do (comp-emit (list 'set (make-comp-mvar :slot 'scratch) - (comp-call test-func var m-test))) - (comp-emit (list 'cond-jump - (make-comp-mvar :slot 'scratch) - (make-comp-mvar :constant nil) - target-name ff-bb-name)) - do (unless last - ;; All fall through are artificially created here except the last one. - (puthash ff-bb-name ff-bb (comp-func-blocks comp-func)) - (setf (comp-limplify-curr-block comp-pass) ff-bb)))) + do (comp-emit (list 'set (make-comp-mvar :slot 'scratch) + (comp-call test-func var m-test))) + (comp-emit (list 'cond-jump + (make-comp-mvar :slot 'scratch) + (make-comp-mvar :constant nil) + target-name ff-bb-name)) + unless last + ;; All fall through are artificially created here except the last one. + do (puthash ff-bb-name ff-bb (comp-func-blocks comp-func)) + (setf (comp-limplify-curr-block comp-pass) ff-bb)))) (_ (signal 'native-ice "missing previous setimm while creating a switch")))) commit 92cf4bb8cc3da81f4877a734b9e9089ac4b89e85 Merge: f8df3320b1 02f5a419fd Author: Andrea Corallo Date: Wed May 6 20:11:59 2020 +0100 Merge remote-tracking branch 'savannah/master' into HEAD commit f8df3320b1ceffca8d5ee7cbc566ba3cdf761e21 Author: Andrea Corallo Date: Wed May 6 18:55:33 2020 +0100 * Add native compilation unit black list * lisp/emacs-lisp/comp.el (comp-bootstrap-black-list): New customize. (batch-native-compile): Rework to make use of 'comp-bootstrap-black-list'. (batch-byte-native-compile-for-bootstrap): Add assertion to make logic assumption explicit. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index bd4c25a1f5..60b41f95bd 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -84,6 +84,13 @@ This intended for debugging the compiler itself. :type 'boolean :group 'comp) +(defcustom comp-bootstrap-black-list + '("^leim/") + "List of regexps to exclude files from native compilation during bootstrap. +Skip if any is matching." + :type 'list + :group 'comp) + (defcustom comp-never-optimize-functions '(;; Mandatory for Emacs to be working correctly macroexpand scroll-down scroll-up narrow-to-region widen rename-buffer @@ -2291,7 +2298,13 @@ Return the compilation unit file name." (defun batch-native-compile () "Run `native-compile' on remaining command-line arguments. Ultra cheap impersonation of `batch-byte-compile'." - (mapc #'native-compile command-line-args-left)) + (cl-loop for file in command-line-args-left + if (or (null byte-native-for-bootstrap) + (cl-notany (lambda (re) (string-match re file)) + comp-bootstrap-black-list)) + do (native-compile file) + else + do (byte-compile-file file))) ;;;###autoload (defun batch-byte-native-compile-for-bootstrap () @@ -2299,6 +2312,7 @@ Ultra cheap impersonation of `batch-byte-compile'." Always generate elc files too and handle native compiler expected errors." (if (equal (getenv "NATIVE_DISABLE") "1") (batch-byte-compile) + (cl-assert (= 1 (length command-line-args-left))) (let ((byte-native-for-bootstrap t) (byte-to-native-output-file nil)) (unwind-protect commit 6d25de46f77909f3adb108786052995151082c56 Author: Andrea Corallo Date: Tue May 5 15:50:30 2020 +0100 * configure.ac: Fix var usage + better messaging. diff --git a/configure.ac b/configure.ac index 62fb274d3b..23b94cf6ca 100644 --- a/configure.ac +++ b/configure.ac @@ -3780,18 +3780,18 @@ AC_DEFUN([libgccjit_broken], [ You can verify it yourself compiling: . Please report the issue to your distribution. -Here instructions on how to compile from source: +Here instructions on how to compile and install libgccjit from source: .])]) HAVE_NATIVE_COMP=no LIBGCCJIT_LIB= COMP_OBJ= if test "${with_nativecomp}" != "no"; then - emacs_save_LDFLAGS=$LDFLAGS - LDFLAGS="-lgccjit" + emacs_save_LIBS=$LIBS + LIBS="-lgccjit" AC_RUN_IFELSE([libgccjit_smoke_test], [], [libgccjit_broken], [AC_LINK_IFELSE([libgccjit_smoke_test], [], [libgccjit_not_found])]) - LDFLAGS=$emacs_save_LDFLAGS + LIBS=$emacs_save_LIBS HAVE_NATIVE_COMP=yes LIBGCCJIT_LIB="-lgccjit -ldl" COMP_OBJ="comp.o" commit a261db171166246eaee523cd3b3687b39bce4dca Author: Andrea Corallo Date: Tue May 5 08:47:51 2020 +0100 * configure.ac: Better messaging when libgccjit fails smoke test * configure.ac: Fix libgccjit test LDFLAGS plus better messaging in case of its fail. diff --git a/configure.ac b/configure.ac index af12f20500..62fb274d3b 100644 --- a/configure.ac +++ b/configure.ac @@ -3777,15 +3777,18 @@ to configure.])]) AC_DEFUN([libgccjit_broken], [ AC_MSG_ERROR([Installed libgccjit has failed passing the smoke test. +You can verify it yourself compiling: +. Please report the issue to your distribution. -Here instructions on how to compile from source: https://gcc.gnu.org/wiki/JIT.])]) +Here instructions on how to compile from source: +.])]) HAVE_NATIVE_COMP=no LIBGCCJIT_LIB= COMP_OBJ= if test "${with_nativecomp}" != "no"; then emacs_save_LDFLAGS=$LDFLAGS - LDFLAGS="-lgccjit -ldl" + LDFLAGS="-lgccjit" AC_RUN_IFELSE([libgccjit_smoke_test], [], [libgccjit_broken], [AC_LINK_IFELSE([libgccjit_smoke_test], [], [libgccjit_not_found])]) LDFLAGS=$emacs_save_LDFLAGS commit 766f4b96ee148adf8f4bbbf5fa4f1c47555d46de Author: Andrea Corallo Date: Mon May 4 21:01:48 2020 +0100 * configure.ac: Add a better libgccjit test plus some morw err message * configure.ac (libgccjit_smoke_test, libgccjit_not_found) (libgccjit_broken): New functions. diff --git a/configure.ac b/configure.ac index c4d19e0e28..af12f20500 100644 --- a/configure.ac +++ b/configure.ac @@ -3729,22 +3729,70 @@ emacs_major_version="${PACKAGE_VERSION%%.*}" AC_SUBST(emacs_major_version) ### Emacs Lisp native compiler support + +AC_DEFUN([libgccjit_smoke_test], [ + AC_LANG_SOURCE( + [[#include + #include + #include + int + main (int argc, char **argv) + { + gcc_jit_context *ctxt; + gcc_jit_result *result; + ctxt = gcc_jit_context_acquire (); + if (!ctxt) + exit (1); + gcc_jit_type *int_type = + gcc_jit_context_get_type (ctxt, GCC_JIT_TYPE_INT); + gcc_jit_function *func = + gcc_jit_context_new_function (ctxt, NULL, + GCC_JIT_FUNCTION_EXPORTED, + int_type, "foo", 0, NULL, 0); + gcc_jit_block *block = gcc_jit_function_new_block (func, "foo"); + gcc_jit_block_end_with_return ( + block, + NULL, + gcc_jit_context_new_rvalue_from_int (ctxt, int_type, 1)); + result = gcc_jit_context_compile (ctxt); + if (!result) + exit (1); + typedef int (*fn_type) (void); + fn_type foo = + (fn_type)gcc_jit_result_get_code (result, "foo"); + if (!foo) + exit (1); + if (foo () != 1) + exit (1); + gcc_jit_context_release (ctxt); + gcc_jit_result_release (result); + return 0; + }]])]) + +AC_DEFUN([libgccjit_not_found], [ + AC_MSG_ERROR([elisp native compiler requested but libgccjit not found. +If you are sure you want Emacs compiled without elisp native compiler, pass + --without-nativecomp +to configure.])]) + +AC_DEFUN([libgccjit_broken], [ + AC_MSG_ERROR([Installed libgccjit has failed passing the smoke test. +Please report the issue to your distribution. +Here instructions on how to compile from source: https://gcc.gnu.org/wiki/JIT.])]) + HAVE_NATIVE_COMP=no LIBGCCJIT_LIB= COMP_OBJ= if test "${with_nativecomp}" != "no"; then - AC_CHECK_HEADER(libgccjit.h, - AC_CHECK_LIB(gccjit, gcc_jit_context_acquire, HAVE_NATIVE_COMP=yes)) - if test "${HAVE_NATIVE_COMP}" = "yes"; then + emacs_save_LDFLAGS=$LDFLAGS + LDFLAGS="-lgccjit -ldl" + AC_RUN_IFELSE([libgccjit_smoke_test], [], [libgccjit_broken], + [AC_LINK_IFELSE([libgccjit_smoke_test], [], [libgccjit_not_found])]) + LDFLAGS=$emacs_save_LDFLAGS + HAVE_NATIVE_COMP=yes LIBGCCJIT_LIB="-lgccjit -ldl" COMP_OBJ="comp.o" AC_DEFINE(HAVE_NATIVE_COMP, 1, [Define to 1 if you have the libgccjit library (-lgccjit).]) - else - AC_MSG_ERROR([elisp native compiler requested but libgccjit not found. -If you are sure you want Emacs compiled without elisp native compiler, pass - --without-nativecomp -to configure.]) - fi fi if test "${HAVE_NATIVE_COMP}" = yes && test "${HAVE_PDUMPER}" = no; then AC_MSG_ERROR(['--with-nativecomp' requires '--with-dumping=pdumper']) commit c6a610ecdcf295d49cb70089f4ecb64768598e99 Merge: 1ec7499e59 2db70edd9c Author: Andrea Corallo Date: Mon May 4 18:24:00 2020 +0100 Merge remote-tracking branch 'savannah/master' into HEAD commit 1ec7499e59a8724cb9f3d8688a7c922acad3be27 Author: Andrea Corallo Date: Sun May 3 13:37:38 2020 +0100 * Add a warning for missing write privilege * lisp/emacs-lisp/comp.el (native-compile-async): Check for write privilege and raise a warning in case. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index f027bad65c..bd4c25a1f5 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2344,7 +2344,16 @@ queued with LOAD %" file load (cdr entry)) ;; Make sure we are not already compiling `file' (bug#40838). (unless (gethash file comp-async-compilations) - (setf comp-files-queue (append comp-files-queue `((,file . ,load))))))) + (let ((out-dir (comp-output-directory file)) + (out-filename (comp-output-filename file))) + (if (or (file-writable-p out-filename) + (and (not (file-exists-p out-dir)) + (file-writable-p (substring out-dir 0 -1)))) + (setf comp-files-queue + (append comp-files-queue `((,file . ,load)))) + (display-warning 'comp + (format "No write access for %s skipping." + out-filename))))))) (when (zerop (comp-async-runnings)) (comp-run-async-workers) (message "Compilation started.")))) commit 8d372201904bcb5fe6cb14aa5c45f33e6e1cd815 Author: Andrea Corallo Date: Sun May 3 14:35:50 2020 +0100 * Introduce `comp-output-directory' * lisp/emacs-lisp/comp.el (comp-output-directory): New function. (comp-output-base-filename): Use `comp-output-directory'. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 05417fdc31..f027bad65c 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -443,13 +443,19 @@ VERBOSITY is a number between 0 and 3." 2)) edges))) +(defun comp-output-directory (src) + "Return the compilation direcotry for source SRC." + (let* ((src (if (symbolp src) (symbol-name src) src)) + (expanded-filename (expand-file-name src))) + (file-name-as-directory + (concat (file-name-directory expanded-filename) + comp-native-path-postfix)))) + (defun comp-output-base-filename (src) "Output filename sans extention for SRC file being native compiled." (let* ((src (if (symbolp src) (symbol-name src) src)) (expanded-filename (expand-file-name src)) - (output-dir (file-name-as-directory - (concat (file-name-directory expanded-filename) - comp-native-path-postfix))) + (output-dir (comp-output-directory src)) (output-filename (file-name-sans-extension (file-name-nondirectory expanded-filename)))) commit 02e3ffad6d9f757599bb441704b6cf6494183174 Author: Andrea Corallo Date: Wed Apr 29 21:21:42 2020 +0100 * Fix async compilation non respecting `comp-always-compile' nil value. * lisp/emacs-lisp/comp.el (comp-run-async-workers): Fix missing `comp-output-filename' usage. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 1dbafbe1ae..05417fdc31 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2196,7 +2196,8 @@ display a message." "`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"))) + (file-newer-than-file-p source-file + (comp-output-filename source-file))) do (let* ((expr `(progn (require 'comp) (setf comp-speed ,comp-speed commit ab66e61b58cd872379e7a9ce301bf0bd17507282 Merge: f8b254d195 b56401f384 Author: Andrea Corallo Date: Wed Apr 29 20:25:23 2020 +0100 Merge remote-tracking branch 'savannah/master' into HEAD commit f8b254d1957a86645bfcc6ce452d97b9286910a2 Author: Andrea Corallo Date: Sun Apr 26 19:55:26 2020 +0100 Rework spill LAP mechanism in preparation of compiling lambdas. * lisp/emacs-lisp/comp.el (comp-spill-lap-function): No need anymore to have `byte-native-compiling' bound to free-func. (comp-spill-lap-function): Make use of `byte-to-native-lap-h' and clean-up. (comp-spill-lap-function): Likewise. * lisp/emacs-lisp/bytecomp.el (byte-to-native-function): Add lap slot. (byte-to-native-lap): Rename into byte-to-native-lap-h. (byte-compile-lapcode): Spill lap after having int assembled and store it into `byte-to-native-lap-h'. (byte-compile-not-top-level): Remove. (byte-compile-file-form-defmumble): Fill directly lap slot. (byte-compile-lambda): Remove `byte-compile-not-top-level'. (byte-compile-out-toplevel): Restore original code. (byte-compile-form): Remove `byte-compile-not-top-level'. (byte-compile-function-form): Likewise. (byte-compile-flush-pending): No need anymore to set `byte-compile-current-form' so restore orignal code. diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 9a5491b10f..8f85c92839 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -565,7 +565,7 @@ Each element is (INDEX . VALUE)") ;; These are use by comp.el to spill data out of here (cl-defstruct byte-to-native-function "Named or anonymous function defined a top level." - name c-name data) + name c-name data lap) (cl-defstruct byte-to-native-top-level "All other top level forms." form) @@ -577,9 +577,8 @@ Each element is (INDEX . VALUE)") ;; Because the make target is the later this has to be produced as ;; last to be resilient against build interruptions. ) -(defvar byte-to-native-lap nil - "A-list to accumulate LAP. -Each pair is (NAME . LAP)") +(defvar byte-to-native-lap-h nil + "Hash byte-code -> LAP.") (defvar byte-to-native-top-level-forms nil "List of top level forms.") (defvar byte-to-native-output-file nil @@ -977,7 +976,11 @@ CONST2 may be evaluated multiple times." ;; it within 2 bytes in the byte string). (puthash value pc hash-table)) hash-table)) - (apply 'unibyte-string (nreverse bytes)))) + (let ((bytecode (apply 'unibyte-string (nreverse bytes)))) + (when byte-native-compiling + ;; Spill LAP for the native compiler here + (puthash bytecode lap byte-to-native-lap-h)) + bytecode))) ;;; compile-time evaluation @@ -1094,8 +1097,6 @@ message buffer `default-directory'." (defvar byte-compile-current-file nil) (defvar byte-compile-current-group nil) (defvar byte-compile-current-buffer nil) -(defvar byte-compile-not-top-level nil ; We'll evolve this for naming lambdas - "Non nil if compiling something that is not top-level.") ;; Log something that isn't a warning. (defmacro byte-compile-log (format-string &rest args) @@ -2363,8 +2364,7 @@ list that represents a doc string reference. (defun byte-compile-flush-pending () (if byte-compile-output - (let* ((byte-compile-current-form nil) - (form (byte-compile-out-toplevel t 'file))) + (let ((form (byte-compile-out-toplevel t 'file))) (cond ((eq (car-safe form) 'progn) (mapc 'byte-compile-output-file-form (cdr form))) (form @@ -2689,7 +2689,10 @@ not to take responsibility for the actual compilation of the code." (push (if macro (make-byte-to-native-top-level :form `(defalias ',name '(macro . ,code) nil)) - (make-byte-to-native-function :name name :data code)) + (make-byte-to-native-function :name name + :data code + :lap (gethash (aref code 1) + byte-to-native-lap-h))) byte-to-native-top-level-forms)) ;; Output the form by hand, that's much simpler than having ;; b-c-output-file-form analyze the defalias. @@ -2918,7 +2921,6 @@ for symbols generated by the byte compiler itself." ;; args of `list'. Actually, compile it to get warnings, ;; but don't use the result. (let* ((form (nth 1 int)) - (byte-compile-not-top-level t) (newform (byte-compile-top-level form))) (while (memq (car-safe form) '(let let* progn save-excursion)) (while (consp (cdr form)) @@ -3116,16 +3118,9 @@ for symbols generated by the byte compiler itself." (not (delq nil (mapcar 'consp (cdr (car body)))))))) (setq rest (cdr rest))) rest)) - (let* ((byte-compile-vector (byte-compile-constants-vector)) - (out (list 'byte-code (byte-compile-lapcode byte-compile-output) - byte-compile-vector byte-compile-maxdepth))) - (when (and byte-native-compiling - (or (null byte-compile-not-top-level) - (eq byte-native-compiling 'free-func))) - ;; Spill LAP for the native compiler here - (push (cons byte-compile-current-form byte-compile-output) - byte-to-native-lap)) - out)) + (let ((byte-compile-vector (byte-compile-constants-vector))) + (list 'byte-code (byte-compile-lapcode byte-compile-output) + byte-compile-vector byte-compile-maxdepth))) ;; it's a trivial function ((cdr body) (cons 'progn (nreverse body))) ((car body))))) @@ -3175,8 +3170,7 @@ for symbols generated by the byte compiler itself." ;; byte-compile--for-effect flag too.) ;; (defun byte-compile-form (form &optional for-effect) - (let ((byte-compile--for-effect for-effect) - (byte-compile-not-top-level t)) + (let ((byte-compile--for-effect for-effect)) (cond ((not (consp form)) (cond ((or (not (symbolp form)) (macroexp--const-symbol-p form)) @@ -3950,8 +3944,7 @@ discarding." ;; and (funcall (function foo)) will lose with autoloads. (defun byte-compile-function-form (form) - (let ((f (nth 1 form)) - (byte-compile-not-top-level t)) + (let ((f (nth 1 form))) (when (and (symbolp f) (byte-compile-warning-enabled-p 'callargs f)) (byte-compile-function-warn f t (byte-compile-fdefinition f nil))) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index f8e30f0047..1dbafbe1ae 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -523,8 +523,7 @@ Put PREFIX in front of it." (cl-defgeneric comp-spill-lap-function ((function-name symbol)) "Byte compile FUNCTION-NAME spilling data from the byte compiler." - (let* ((byte-native-compiling 'free-func) - (f (symbol-function function-name)) + (let* ((f (symbol-function function-name)) (c-name (comp-c-func-name function-name "F")) (func (make-comp-func :name function-name :c-name c-name @@ -535,7 +534,8 @@ Put PREFIX in front of it." "can't native compile an already bytecompiled function")) (setf (comp-func-byte-func func) (byte-compile (comp-func-name func))) - (let ((lap (alist-get nil byte-to-native-lap))) + (let ((lap (gethash (aref (comp-func-byte-func func) 1) + byte-to-native-lap-h))) (cl-assert lap) (comp-log lap 2) (let ((arg-list (aref (comp-func-byte-func func) 0))) @@ -559,9 +559,7 @@ Put PREFIX in front of it." (signal 'native-compiler-error-empty-byte filename)) (setf (comp-ctxt-top-level-forms comp-ctxt) (reverse byte-to-native-top-level-forms)) - (comp-log byte-to-native-lap 3) (cl-loop - with lap-forms = (reverse byte-to-native-lap) ;; All non anonymous functions. for f in (cl-loop for x in (comp-ctxt-top-level-forms comp-ctxt) when (and (byte-to-native-function-p x) @@ -569,8 +567,6 @@ Put PREFIX in front of it." collect x) for name = (byte-to-native-function-name f) for c-name = (comp-c-func-name name "F") - for lap-entry = (assoc name lap-forms) - for lap = (cdr lap-entry) for data = (byte-to-native-function-data f) for func = (make-comp-func :name name :byte-func data @@ -578,12 +574,9 @@ Put PREFIX in front of it." :int-spec (interactive-form data) :c-name c-name :args (comp-decrypt-arg-list (aref data 0) name) - :lap lap + :lap (byte-to-native-function-lap f) :frame-size (comp-byte-frame-size data)) do - ;; Remove it form the original lap list to avoid multiple function - ;; definition with the same name shadowing each other. - (setf lap-forms (delete lap-entry lap-forms)) ;; Store the c-name to have it retrivable from ;; comp-ctxt-top-level-forms. (setf (byte-to-native-function-c-name f) c-name) @@ -591,14 +584,14 @@ Put PREFIX in front of it." (puthash 0 (comp-func-frame-size func) (comp-func-array-h func)) (comp-add-func-to-ctxt func) (comp-log (format "Function %s:\n" name) 1) - (comp-log lap 1))) + (comp-log (byte-to-native-function-lap f) 1))) (defun comp-spill-lap (input) "Byte compile and spill the LAP representation for INPUT. If INPUT is a symbol this is the function-name to be compiled. If INPUT is a string this is the file path to be compiled." (let ((byte-native-compiling t) - (byte-to-native-lap ()) + (byte-to-native-lap-h (make-hash-table :test #'eq)) (byte-to-native-top-level-forms ())) (comp-spill-lap-function input))) commit e6fb440ed7e48c2e8c4bba4666db2f0ff9950a25 Merge: bb4cf13c47 453ada0309 Author: Andrea Corallo Date: Sun Apr 26 10:24:26 2020 +0100 Merge remote-tracking branch 'savannah/master' into HEAD commit bb4cf13c47a1a24ce83233cc7b77dc87fc274d52 Author: Andrea Corallo Date: Sun Apr 26 09:11:33 2020 +0100 Convert before final function doc hash into a vector. * lisp/emacs-lisp/comp.el (comp-finalize-relocs): Convert doc hash table into vector befor final. (comp-emit-for-top-level): Rename `comp-ctxt-doc-index-h' -> `comp-ctxt-function-docs'. (comp-ctxt): Likewise. * src/comp.c (native_function_doc): Update logic for documentation being a vector. (emit_ctxt_code): Update for 'comp-ctxt-doc-index-h' slot rename. * src/comp.h (struct Lisp_Native_Comp_Unit): Rename 'data_fdoc_h' into data_fdoc_v. * src/pdumper.c (dump_native_comp_unit): Likewise. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 5096a143a0..f8e30f0047 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -216,7 +216,7 @@ Can be one of: 'd-default', 'd-impure' or 'd-ephemeral'. See `comp-ctxt'.") (sym-to-c-name-h (make-hash-table :test #'eq) :type hash-table :documentation "symbol-function -> c-name. This is only for optimizing intra CU calls at speed 3.") - (doc-index-h (make-hash-table :test #'eql) :type hash-table + (function-docs (make-hash-table :test #'eql) :type (or hash-table vector) :documentation "Documentation index -> documentation") (d-default (make-comp-data-container) :type comp-data-container :documentation "Standard data relocated in use by functions.") @@ -1218,7 +1218,7 @@ the annotation emission." (make-comp-mvar :constant c-name) (make-comp-mvar :constant - (let* ((h (comp-ctxt-doc-index-h comp-ctxt)) + (let* ((h (comp-ctxt-function-docs comp-ctxt)) (i (hash-table-count h))) (puthash i (comp-func-doc f) h) i)) @@ -2103,7 +2103,15 @@ Update all insn accordingly." do (remhash obj d-ephemeral-idx)) ;; Fix-up indexes in each relocation class and fill corresponding ;; reloc lists. - (mapc #'comp-finalize-container (list d-default d-impure d-ephemeral)))) + (mapc #'comp-finalize-container (list d-default d-impure d-ephemeral)) + ;; Make a vector from the function documentation hash table. + (cl-loop with h = (comp-ctxt-function-docs comp-ctxt) + with v = (make-vector (hash-table-count h) nil) + for idx being each hash-keys of h + for doc = (gethash idx h) + do (setf (aref v idx) doc) + finally + do (setf (comp-ctxt-function-docs comp-ctxt) v)))) (defun comp-compile-ctxt-to-file (name) "Compile as native code the current context naming it NAME. diff --git a/src/comp.c b/src/comp.c index b33ef92f72..d021be479b 100644 --- a/src/comp.c +++ b/src/comp.c @@ -2102,7 +2102,7 @@ emit_ctxt_code (void) emit_static_object (TEXT_OPTIM_QLY_SYM, Flist (2, opt_qly)); emit_static_object (TEXT_FDOC_SYM, - CALL1I (comp-ctxt-doc-index-h, Vcomp_ctxt)); + CALL1I (comp-ctxt-function-docs, Vcomp_ctxt)); comp.current_thread_ref = gcc_jit_lvalue_as_rvalue ( @@ -3677,14 +3677,12 @@ native_function_doc (Lisp_Object function) struct Lisp_Native_Comp_Unit *cu = XNATIVE_COMP_UNIT (Fsubr_native_comp_unit (function)); - if (NILP (cu->data_fdoc_h)) - cu->data_fdoc_h = load_static_obj (cu, TEXT_FDOC_SYM); - - eassert (!NILP (cu->data_fdoc_h)); - - return Fgethash (make_fixnum (XSUBR (function)->doc), - cu->data_fdoc_h, - Qnil); + if (NILP (cu->data_fdoc_v)) + cu->data_fdoc_v = load_static_obj (cu, TEXT_FDOC_SYM); + if (!VECTORP (cu->data_fdoc_v)) + xsignal2 (Qnative_lisp_file_inconsistent, cu->file, + build_string ("missing documentation vector")); + return AREF (cu->data_fdoc_v, XSUBR (function)->doc); } DEFUN ("comp--register-subr", Fcomp__register_subr, Scomp__register_subr, diff --git a/src/comp.h b/src/comp.h index 73baa27276..cbdcaccd5f 100644 --- a/src/comp.h +++ b/src/comp.h @@ -38,7 +38,7 @@ struct Lisp_Native_Comp_Unit Lisp_Object file; Lisp_Object optimize_qualities; /* Hash doc-idx -> function documentaiton. */ - Lisp_Object data_fdoc_h; + Lisp_Object data_fdoc_v; /* Analogous to the constant vector but per compilation unit. */ Lisp_Object data_vec; /* Same but for data that cannot be moved to pure space. diff --git a/src/pdumper.c b/src/pdumper.c index c9015d503c..f837dfc38d 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -2982,7 +2982,7 @@ dump_native_comp_unit (struct dump_context *ctx, struct Lisp_Native_Comp_Unit *comp_u) { /* Have function documentation always lazy loaded to optimize load-time. */ - comp_u->data_fdoc_h = Qnil; + comp_u->data_fdoc_v = Qnil; START_DUMP_PVEC (ctx, &comp_u->header, struct Lisp_Native_Comp_Unit, out); dump_pseudovector_lisp_fields (ctx, &out->header, &comp_u->header); out->handle = NULL; commit 2878624980a116550e8b07acc76a24c373eab342 Merge: 64af8f941f 519567878f Author: Andrea Corallo Date: Sat Apr 25 22:22:16 2020 +0100 Merge remote-tracking branch 'savannah/master' into HEAD commit 64af8f941fb7ec50460f47997109e757cb7af94c Author: Andrea Corallo Date: Sat Apr 25 22:08:11 2020 +0100 * src/data.c (syms_of_data): Fix #ifdef HAVE_NATIVE_COMP position. diff --git a/src/data.c b/src/data.c index 1809d58c2c..56ea7aabb0 100644 --- a/src/data.c +++ b/src/data.c @@ -4013,8 +4013,8 @@ syms_of_data (void) defsubr (&Sbyteorder); defsubr (&Ssubr_arity); defsubr (&Ssubr_name); -#ifdef HAVE_NATIVE_COMP defsubr (&Ssubr_native_elisp_p); +#ifdef HAVE_NATIVE_COMP defsubr (&Ssubr_native_comp_unit); defsubr (&Snative_comp_unit_file); defsubr (&Snative_comp_unit_set_file); commit 9f5b7eb5e05948ccdd7fa2a473e5a55889f5e4ee Author: Andrea Corallo Date: Sat Apr 25 20:22:17 2020 +0100 * src/comp.h (Fnative_elisp_load): Add fake inline for stock build. diff --git a/src/comp.h b/src/comp.h index 5beedcfc28..73baa27276 100644 --- a/src/comp.h +++ b/src/comp.h @@ -82,6 +82,12 @@ maybe_defer_native_compilation (Lisp_Object function_name, Lisp_Object definition) {} +static inline Lisp_Object +Fnative_elisp_load (Lisp_Object file, Lisp_Object late_load) +{ + eassume (false); +} + #endif #endif commit 57fa590aa6d4aecef84e548fd17a7178cf3365f0 Author: Andrea Corallo Date: Sat Apr 25 20:07:40 2020 +0100 * src/pdumper.c (dump_subr): Clean-up now unnecessary kludge. diff --git a/src/pdumper.c b/src/pdumper.c index 39adaf3ea2..c9015d503c 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -2937,10 +2937,7 @@ dump_bool_vector (struct dump_context *ctx, const struct Lisp_Vector *v) static dump_off dump_subr (struct dump_context *ctx, const struct Lisp_Subr *subr) { -#if CHECK_STRUCTS && ((defined (HAVE_NATIVE_COMP) \ - && !defined (HASH_Lisp_Subr_99B6674034)) \ - || (!defined (HAVE_NATIVE_COMP) \ - && !defined (HASH_Lisp_Subr_594AB72B54))) +#if CHECK_STRUCTS && !defined (HASH_Lisp_Subr_99B6674034) # error "Lisp_Subr changed. See CHECK_STRUCTS comment in config.h." #endif struct Lisp_Subr out; commit a7fac2e91fb424fcf47ea8a23c218c272dd83434 Author: Andrea Corallo Date: Sat Apr 25 18:16:17 2020 +0100 Lazy load function documentation. * src/comp.c (native_function_doc): New function. (load_comp_unit): Do not load function doc during load. * src/comp.h: Extern 'native_function_doc'. * src/doc.c (Fdocumentation): Call 'native_function_doc' to retrive function doc. * src/pdumper.c (dump_native_comp_unit): Zero 'data_fdoc_h' before dumping. diff --git a/src/comp.c b/src/comp.c index 70b0a25a9c..b33ef92f72 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3627,7 +3627,6 @@ load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u, bool loading_dump, comp_u->data_vec = load_static_obj (comp_u, TEXT_DATA_RELOC_SYM); comp_u->data_impure_vec = load_static_obj (comp_u, TEXT_DATA_RELOC_IMPURE_SYM); - comp_u->data_fdoc_h = load_static_obj (comp_u, TEXT_FDOC_SYM); if (!NILP (Vpurify_flag)) /* Non impure can be copied into pure space. */ @@ -3672,6 +3671,22 @@ load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u, bool loading_dump, return; } +Lisp_Object +native_function_doc (Lisp_Object function) +{ + struct Lisp_Native_Comp_Unit *cu = + XNATIVE_COMP_UNIT (Fsubr_native_comp_unit (function)); + + if (NILP (cu->data_fdoc_h)) + cu->data_fdoc_h = load_static_obj (cu, TEXT_FDOC_SYM); + + eassert (!NILP (cu->data_fdoc_h)); + + return Fgethash (make_fixnum (XSUBR (function)->doc), + cu->data_fdoc_h, + Qnil); +} + DEFUN ("comp--register-subr", Fcomp__register_subr, Scomp__register_subr, 7, 7, 0, doc: /* This gets called by top_level_run during load phase to register diff --git a/src/comp.h b/src/comp.h index c059846811..5beedcfc28 100644 --- a/src/comp.h +++ b/src/comp.h @@ -69,6 +69,8 @@ extern void hash_native_abi (void); extern void load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u, bool loading_dump, bool late_load); +extern Lisp_Object native_function_doc (Lisp_Object function); + extern void syms_of_comp (void); extern void maybe_defer_native_compilation (Lisp_Object function_name, diff --git a/src/doc.c b/src/doc.c index 8191a914c6..31ccee8079 100644 --- a/src/doc.c +++ b/src/doc.c @@ -337,10 +337,7 @@ string is passed through `substitute-command-keys'. */) fun = XCDR (fun); #ifdef HAVE_NATIVE_COMP if (!NILP (Fsubr_native_elisp_p (fun))) - doc = - Fgethash (make_fixnum (XSUBR (fun)->doc), - XNATIVE_COMP_UNIT (Fsubr_native_comp_unit (fun))->data_fdoc_h, - Qnil); + doc = native_function_doc (fun); else #endif if (SUBRP (fun)) diff --git a/src/pdumper.c b/src/pdumper.c index 702b3ffced..39adaf3ea2 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -2982,8 +2982,10 @@ dump_subr (struct dump_context *ctx, const struct Lisp_Subr *subr) #ifdef HAVE_NATIVE_COMP static dump_off dump_native_comp_unit (struct dump_context *ctx, - const struct Lisp_Native_Comp_Unit *comp_u) + struct Lisp_Native_Comp_Unit *comp_u) { + /* Have function documentation always lazy loaded to optimize load-time. */ + comp_u->data_fdoc_h = Qnil; START_DUMP_PVEC (ctx, &comp_u->header, struct Lisp_Native_Comp_Unit, out); dump_pseudovector_lisp_fields (ctx, &out->header, &comp_u->header); out->handle = NULL; commit f691af80f1c2073e610a382029790f7c6f97dd5d Author: Andrea Corallo Date: Sat Apr 25 18:10:06 2020 +0100 * src/comp.h (load_comp_unit): Fix declaration style. diff --git a/src/comp.h b/src/comp.h index 6710227b44..c059846811 100644 --- a/src/comp.h +++ b/src/comp.h @@ -66,8 +66,9 @@ XNATIVE_COMP_UNIT (Lisp_Object a) extern void hash_native_abi (void); -void load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u, bool loading_dump, - bool late_load); +extern void load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u, + bool loading_dump, bool late_load); + extern void syms_of_comp (void); extern void maybe_defer_native_compilation (Lisp_Object function_name, commit e95dca6683e9c8cd08f38bb4f73cbade06cfb209 Author: Andrea Corallo Date: Sat Apr 25 17:33:58 2020 +0100 * Rename TEXT_OPTIM_QLY into TEXT_OPTIM_QLY_SYM. * src/comp.c (TEXT_OPTIM_QLY): Rename into TEXT_OPTIM_QLY_SYM. (emit_ctxt_code): Update TEXT_OPTIM_QLY naming. (load_comp_unit): Likewise. diff --git a/src/comp.c b/src/comp.c index e95ab51cb5..70b0a25a9c 100644 --- a/src/comp.c +++ b/src/comp.c @@ -49,7 +49,7 @@ along with GNU Emacs. If not, see . */ #define TEXT_DATA_RELOC_IMPURE_SYM "text_data_reloc_imp" #define TEXT_DATA_RELOC_EPHEMERAL_SYM "text_data_reloc_eph" -#define TEXT_OPTIM_QLY "text_optim_qly" +#define TEXT_OPTIM_QLY_SYM "text_optim_qly" #define TEXT_FDOC_SYM "text_data_fdoc" @@ -2099,7 +2099,7 @@ emit_ctxt_code (void) Fsymbol_value (Qcomp_speed)), Fcons (Qcomp_debug, Fsymbol_value (Qcomp_debug)) }; - emit_static_object (TEXT_OPTIM_QLY, Flist (2, opt_qly)); + emit_static_object (TEXT_OPTIM_QLY_SYM, Flist (2, opt_qly)); emit_static_object (TEXT_FDOC_SYM, CALL1I (comp-ctxt-doc-index-h, Vcomp_ctxt)); @@ -3622,7 +3622,8 @@ load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u, bool loading_dump, /* Imported data. */ if (!loading_dump) { - comp_u->optimize_qualities = load_static_obj (comp_u, TEXT_OPTIM_QLY); + comp_u->optimize_qualities = + load_static_obj (comp_u, TEXT_OPTIM_QLY_SYM); comp_u->data_vec = load_static_obj (comp_u, TEXT_DATA_RELOC_SYM); comp_u->data_impure_vec = load_static_obj (comp_u, TEXT_DATA_RELOC_IMPURE_SYM); commit d3984becca4111d55c540ecab93c5075efa5afba Author: Andrea Corallo Date: Sat Apr 25 16:50:50 2020 +0100 * src/comp.c (declare_function): fix missing NILP. diff --git a/src/comp.c b/src/comp.c index 2f59164b77..e95ab51cb5 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3016,7 +3016,7 @@ declare_function (Lisp_Object func) gcc_jit_function *gcc_func; char *c_name = SSDATA (CALL1I (comp-func-c-name, func)); Lisp_Object args = CALL1I (comp-func-args, func); - bool nargs = (CALL1I (comp-nargs-p, args)); + bool nargs = !NILP (CALL1I (comp-nargs-p, args)); USE_SAFE_ALLOCA; if (!nargs) commit d73e64076e08cf0bcb81ea9d161fb7409e1bf896 Author: Andrea Corallo Date: Sat Apr 25 16:13:03 2020 +0100 Store function documentations in a hash table. * src/pdumper.c (dump_subr): Update Lisp_Subr hash. (dump_subr): Update for new compilation unit layout. (dump_vectorlike): Update pvec_type hash. * src/lisp.h (struct Lisp_Subr): Remove 'native_doc' index. (DEFUN): Update macro for new compilation unit layout. * src/doc.c (Fdocumentation): Update for new compilation unit layout. * src/comp.h (struct Lisp_Native_Comp_Unit): Add 'data_fdoc_h' field. * src/comp.c (TEXT_FDOC_SYM): New macro. (emit_ctxt_code): Emit function documentations. (load_comp_unit): Load function documentation. (Fcomp__register_subr): Rename parameter. (Fcomp__register_subr): Update for new compilation unit layout. * src/alloc.c (mark_object): Update for new compilation unit layout. (syms_of_alloc): Likewise. * lisp/emacs-lisp/comp.el (comp-ctxt): Add doc-index-h slot. (comp-emit-for-top-level): Emit doc index as 'comp--register-subr' doc parameter. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index e96de27335..5096a143a0 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -216,6 +216,8 @@ Can be one of: 'd-default', 'd-impure' or 'd-ephemeral'. See `comp-ctxt'.") (sym-to-c-name-h (make-hash-table :test #'eq) :type hash-table :documentation "symbol-function -> c-name. This is only for optimizing intra CU calls at speed 3.") + (doc-index-h (make-hash-table :test #'eql) :type hash-table + :documentation "Documentation index -> documentation") (d-default (make-comp-data-container) :type comp-data-container :documentation "Standard data relocated in use by functions.") (d-impure (make-comp-data-container) :type comp-data-container @@ -1214,7 +1216,12 @@ the annotation emission." (comp-args-max args) 'many)) (make-comp-mvar :constant c-name) - (make-comp-mvar :constant (comp-func-doc f)) + (make-comp-mvar + :constant + (let* ((h (comp-ctxt-doc-index-h comp-ctxt)) + (i (hash-table-count h))) + (puthash i (comp-func-doc f) h) + i)) (make-comp-mvar :constant (comp-func-int-spec f)) ;; This is the compilation unit it-self passed as diff --git a/src/alloc.c b/src/alloc.c index 147e018095..f2b80fac88 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -6638,7 +6638,6 @@ mark_object (Lisp_Object arg) set_vector_marked (ptr); struct Lisp_Subr *subr = XSUBR (obj); mark_object (subr->native_intspec); - mark_object (subr->native_doc); mark_object (subr->native_comp_u[0]); } break; @@ -7529,14 +7528,14 @@ N should be nonnegative. */); static union Aligned_Lisp_Subr Swatch_gc_cons_threshold = {{{ PSEUDOVECTOR_FLAG | (PVEC_SUBR << PSEUDOVECTOR_AREA_BITS) }, { .a4 = watch_gc_cons_threshold }, - 4, 4, "watch_gc_cons_threshold", {0}, {0}}}; + 4, 4, "watch_gc_cons_threshold", {0}, 0}}; XSETSUBR (watcher, &Swatch_gc_cons_threshold.s); Fadd_variable_watcher (Qgc_cons_threshold, watcher); static union Aligned_Lisp_Subr Swatch_gc_cons_percentage = {{{ PSEUDOVECTOR_FLAG | (PVEC_SUBR << PSEUDOVECTOR_AREA_BITS) }, { .a4 = watch_gc_cons_percentage }, - 4, 4, "watch_gc_cons_percentage", {0}, {0}}}; + 4, 4, "watch_gc_cons_percentage", {0}, 0}}; XSETSUBR (watcher, &Swatch_gc_cons_percentage.s); Fadd_variable_watcher (Qgc_cons_percentage, watcher); } diff --git a/src/comp.c b/src/comp.c index 4bd271402c..2f59164b77 100644 --- a/src/comp.c +++ b/src/comp.c @@ -41,13 +41,17 @@ along with GNU Emacs. If not, see . */ #define DATA_RELOC_SYM "d_reloc" #define DATA_RELOC_IMPURE_SYM "d_reloc_imp" #define DATA_RELOC_EPHEMERAL_SYM "d_reloc_eph" + #define FUNC_LINK_TABLE_SYM "freloc_link_table" #define LINK_TABLE_HASH_SYM "freloc_hash" #define COMP_UNIT_SYM "comp_unit" #define TEXT_DATA_RELOC_SYM "text_data_reloc" #define TEXT_DATA_RELOC_IMPURE_SYM "text_data_reloc_imp" #define TEXT_DATA_RELOC_EPHEMERAL_SYM "text_data_reloc_eph" + #define TEXT_OPTIM_QLY "text_optim_qly" +#define TEXT_FDOC_SYM "text_data_fdoc" + #define SPEED XFIXNUM (Fsymbol_value (Qcomp_speed)) #define COMP_DEBUG XFIXNUM (Fsymbol_value (Qcomp_debug)) @@ -2097,6 +2101,9 @@ emit_ctxt_code (void) Fsymbol_value (Qcomp_debug)) }; emit_static_object (TEXT_OPTIM_QLY, Flist (2, opt_qly)); + emit_static_object (TEXT_FDOC_SYM, + CALL1I (comp-ctxt-doc-index-h, Vcomp_ctxt)); + comp.current_thread_ref = gcc_jit_lvalue_as_rvalue ( gcc_jit_context_new_global ( @@ -3619,6 +3626,7 @@ load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u, bool loading_dump, comp_u->data_vec = load_static_obj (comp_u, TEXT_DATA_RELOC_SYM); comp_u->data_impure_vec = load_static_obj (comp_u, TEXT_DATA_RELOC_IMPURE_SYM); + comp_u->data_fdoc_h = load_static_obj (comp_u, TEXT_FDOC_SYM); if (!NILP (Vpurify_flag)) /* Non impure can be copied into pure space. */ @@ -3668,7 +3676,7 @@ DEFUN ("comp--register-subr", Fcomp__register_subr, Scomp__register_subr, doc: /* This gets called by top_level_run during load phase to register each exported subr. */) (Lisp_Object name, Lisp_Object minarg, Lisp_Object maxarg, - Lisp_Object c_name, Lisp_Object doc, Lisp_Object intspec, + Lisp_Object c_name, Lisp_Object doc_idx, Lisp_Object intspec, Lisp_Object comp_u) { dynlib_handle_ptr handle = XNATIVE_COMP_UNIT (comp_u)->handle; @@ -3688,7 +3696,7 @@ DEFUN ("comp--register-subr", Fcomp__register_subr, Scomp__register_subr, x->s.max_args = FIXNUMP (maxarg) ? XFIXNUM (maxarg) : MANY; x->s.symbol_name = xstrdup (SSDATA (Fsymbol_name (name))); x->s.native_intspec = intspec; - x->s.native_doc = doc; + x->s.doc = XFIXNUM (doc_idx); x->s.native_comp_u[0] = comp_u; Lisp_Object tem; XSETSUBR (tem, &x->s); diff --git a/src/comp.h b/src/comp.h index f5baa88853..6710227b44 100644 --- a/src/comp.h +++ b/src/comp.h @@ -37,6 +37,8 @@ struct Lisp_Native_Comp_Unit /* Original eln file loaded. */ Lisp_Object file; Lisp_Object optimize_qualities; + /* Hash doc-idx -> function documentaiton. */ + Lisp_Object data_fdoc_h; /* Analogous to the constant vector but per compilation unit. */ Lisp_Object data_vec; /* Same but for data that cannot be moved to pure space. diff --git a/src/doc.c b/src/doc.c index 1b6aa01ef0..8191a914c6 100644 --- a/src/doc.c +++ b/src/doc.c @@ -337,7 +337,10 @@ string is passed through `substitute-command-keys'. */) fun = XCDR (fun); #ifdef HAVE_NATIVE_COMP if (!NILP (Fsubr_native_elisp_p (fun))) - doc = XSUBR (fun)->native_doc; + doc = + Fgethash (make_fixnum (XSUBR (fun)->doc), + XNATIVE_COMP_UNIT (Fsubr_native_comp_unit (fun))->data_fdoc_h, + Qnil); else #endif if (SUBRP (fun)) diff --git a/src/lisp.h b/src/lisp.h index 1cec62a853..3d082911f5 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -2098,10 +2098,7 @@ struct Lisp_Subr const char *intspec; Lisp_Object native_intspec; }; - union { - EMACS_INT doc; - Lisp_Object native_doc; - }; + EMACS_INT doc; Lisp_Object native_comp_u[NATIVE_COMP_FLAG]; } GCALIGNED_STRUCT; union Aligned_Lisp_Subr @@ -3077,7 +3074,7 @@ CHECK_INTEGER (Lisp_Object x) static union Aligned_Lisp_Subr sname = \ {{{ PVEC_SUBR << PSEUDOVECTOR_AREA_BITS }, \ { .a ## maxargs = fnname }, \ - minargs, maxargs, lname, {intspec}, {0}}}; \ + minargs, maxargs, lname, {intspec}, 0}}; \ Lisp_Object fnname /* defsubr (Sname); diff --git a/src/pdumper.c b/src/pdumper.c index bf6bc3a3bc..702b3ffced 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -2938,7 +2938,7 @@ static dump_off dump_subr (struct dump_context *ctx, const struct Lisp_Subr *subr) { #if CHECK_STRUCTS && ((defined (HAVE_NATIVE_COMP) \ - && !defined (HASH_Lisp_Subr_D4F15794AF)) \ + && !defined (HASH_Lisp_Subr_99B6674034)) \ || (!defined (HAVE_NATIVE_COMP) \ && !defined (HASH_Lisp_Subr_594AB72B54))) # error "Lisp_Subr changed. See CHECK_STRUCTS comment in config.h." @@ -2959,14 +2959,13 @@ dump_subr (struct dump_context *ctx, const struct Lisp_Subr *subr) COLD_OP_NATIVE_SUBR, make_lisp_ptr ((void *) subr, Lisp_Vectorlike)); dump_field_lv (ctx, &out, subr, &subr->native_intspec, WEIGHT_NORMAL); - dump_field_lv (ctx, &out, subr, &subr->native_doc, WEIGHT_NORMAL); } else { dump_field_emacs_ptr (ctx, &out, subr, &subr->symbol_name); dump_field_emacs_ptr (ctx, &out, subr, &subr->intspec); - DUMP_FIELD_COPY (&out, subr, doc); } + DUMP_FIELD_COPY (&out, subr, doc); if (NATIVE_COMP_FLAG) dump_field_lv (ctx, &out, subr, &subr->native_comp_u[0], WEIGHT_NORMAL); @@ -3023,7 +3022,7 @@ dump_vectorlike (struct dump_context *ctx, Lisp_Object lv, dump_off offset) { -#if CHECK_STRUCTS && !defined HASH_pvec_type_A4A6E9984D +#if CHECK_STRUCTS && !defined HASH_pvec_type_F5BA506141 # error "pvec_type changed. See CHECK_STRUCTS comment in config.h." #endif const struct Lisp_Vector *v = XVECTOR (lv); commit 9c4c0af89d88f5b4a9124741f64915c5378f1283 Author: Andrea Corallo Date: Sat Apr 25 15:43:10 2020 +0100 * lisp/emacs-lisp/comp.el (comp-run-async-workers): Use `clrhash'. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 42c40aaa43..e96de27335 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2230,7 +2230,7 @@ display a message." (insert msg "\n"))) ;; `comp-deferred-pending-h' should be empty at this stage. ;; Reset it anyway. - (setf comp-deferred-pending-h (make-hash-table :test #'eq)) + (clrhash comp-deferred-pending-h) (message msg)))) commit c984a53b4e198e31d11d7bc493dc9a686c77edae Merge: bab36619fb f7748ad682 Author: Andrea Corallo Date: Sat Apr 25 15:13:18 2020 +0100 Merge remote-tracking branch 'savannah/master' into HEAD commit bab36619fb26059e3ac7c794738be4314c681e08 Author: Andrea Corallo Date: Sat Apr 25 14:45:21 2020 +0100 Fix deferred-compilation for double compilation (bug#40838). * lisp/emacs-lisp/comp.el (native-compile-async): Prevent double compilation (bug#40838). diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 1369dd115d..42c40aaa43 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2327,7 +2327,9 @@ LOAD can be nil t or 'late." nil "Trying to queue %s with LOAD %s but this is already \ queued with LOAD %" file load (cdr entry)) - (setf comp-files-queue (append comp-files-queue `((,file . ,load)))))) + ;; Make sure we are not already compiling `file' (bug#40838). + (unless (gethash file comp-async-compilations) + (setf comp-files-queue (append comp-files-queue `((,file . ,load))))))) (when (zerop (comp-async-runnings)) (comp-run-async-workers) (message "Compilation started.")))) commit e208de9d259cb50c19d1f2a5086fd8301ac71781 Author: Andrea Corallo Date: Sat Apr 25 14:39:11 2020 +0100 Store ongoing compilations processes as hash table. * lisp/emacs-lisp/comp.el (comp-async-processes): Rename as `comp-async-compilations'. (comp-async-runnings): Make use as `comp-async-compilations'. (comp-run-async-workers): Likewise. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 1693e06018..1369dd115d 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2146,16 +2146,21 @@ Prepare every function for final compilation and drive the C back-end." (defvar comp-files-queue () "List of Elisp files to be compiled.") -(defvar comp-async-processes () - "List of running async compilation processes.") +(defvar comp-async-compilations (make-hash-table :test #'equal) + "Hash table file-name -> async compilation process.") (defun comp-async-runnings () "Return the number of async compilations currently running. This function has the side effect of cleaning-up finished -processes from `comp-async-processes'" - (setf comp-async-processes - (cl-delete-if-not #'process-live-p comp-async-processes)) - (length comp-async-processes)) +processes from `comp-async-compilations'" + (cl-loop + for file-name in (cl-loop + for file-name being each hash-key of comp-async-compilations + for prc = (gethash file-name comp-async-compilations) + unless (process-live-p prc) + collect file-name) + do (remhash file-name comp-async-compilations)) + (hash-table-count comp-async-compilations)) (let (num-cpus) (defun comp-effective-async-max-jobs () @@ -2213,7 +2218,7 @@ display a message." (comp-output-filename source-file1) (eq load1 'late))) (comp-run-async-workers))))) - (push process comp-async-processes)) + (puthash source-file process comp-async-compilations)) when (>= (comp-async-runnings) (comp-effective-async-max-jobs)) do (cl-return))) ;; No files left to compile and all processes finished. commit e527d1ab285e9a6611dc23ea8eae9ae9d8e163bb Merge: 3ac3ba22be 367b55980f Author: Andrea Corallo Date: Fri Apr 24 16:51:00 2020 +0100 Merge remote-tracking branch 'savannah/master' into HEAD commit 3ac3ba22be5fa08434ef7e2e37ad2376798f61ef Author: Andrea Corallo Date: Fri Apr 24 19:24:07 2020 +0100 * lisp/subr.el (called-interactively-p): Fix for native code bug#40694. diff --git a/lisp/subr.el b/lisp/subr.el index 1dd768c3a6..5cf80f8e4b 100644 --- a/lisp/subr.el +++ b/lisp/subr.el @@ -5131,7 +5131,7 @@ command is called from a keyboard macro?" ;; Now `frame' should be "the function from which we were called". (pcase (cons frame nextframe) ;; No subr calls `interactive-p', so we can rule that out. - (`((,_ ,(pred (lambda (f) (subrp (indirect-function f)))) . ,_) . ,_) nil) + (`((,_ ,(pred (lambda (f) (subr-primitive-p (indirect-function f)))) . ,_) . ,_) nil) ;; In case # without going through the ;; `funcall-interactively' symbol (bug#3984). (`(,_ . (t ,(pred (lambda (f) commit c120dbc73a0c7f17f6dab190544c0b43f56ec206 Author: Andrea Corallo Date: Fri Apr 24 19:23:34 2020 +0100 * lisp/subr.el (subr-primitive-p): New inline function. diff --git a/lisp/subr.el b/lisp/subr.el index 006766587b..1dd768c3a6 100644 --- a/lisp/subr.el +++ b/lisp/subr.el @@ -233,6 +233,11 @@ value of last one, or nil if there are none. (declare (indent 1) (debug t)) (cons 'if (cons cond (cons nil body)))) +(defsubst subr-primitive-p (object) + "Return t if OBJECT is a built-in primitive function." + (and (subrp object) + (not (subr-native-elisp-p object)))) + (defsubst xor (cond1 cond2) "Return the boolean exclusive-or of COND1 and COND2. If only one of the arguments is non-nil, return it; otherwise commit b380451c6a6f1464520e2cb431aacea84f933b32 Author: Andrea Corallo Date: Fri Apr 24 19:02:55 2020 +0100 * lisp/emacs-lisp/comp.el (comp-run-async-workers): Fix non late load. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 7486e80749..1693e06018 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2211,7 +2211,7 @@ display a message." (zerop (process-exit-status process))) (native-elisp-load (comp-output-filename source-file1) - load1)) + (eq load1 'late))) (comp-run-async-workers))))) (push process comp-async-processes)) when (>= (comp-async-runnings) (comp-effective-async-max-jobs)) commit 81389d5f2dcb41730dcbc76874cc14eadb53ae75 Author: Andrea Corallo Date: Thu Apr 23 08:54:46 2020 +0100 * lisp/emacs-lisp/bytecomp.el (byte-compile-refresh-preloaded): Add comp.eln diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index ff84d94897..9a5491b10f 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -5148,7 +5148,8 @@ Use with caution." (message "Can't find %s to refresh preloaded Lisp files" argv0) (dolist (f (reverse load-history)) (setq f (car f)) - (if (string-match "elc\\'" f) (setq f (substring f 0 -1))) + (when (string-match "el[cn]\\'" f) + (setq f (substring f 0 -1))) (when (and (file-readable-p f) (file-newer-than-file-p f emacs-file) ;; Don't reload the source version of the files below @@ -5157,7 +5158,7 @@ Use with caution." ;; so it can cause recompilation to fail. (not (member (file-name-nondirectory f) '("pcase.el" "bytecomp.el" "macroexp.el" - "cconv.el" "byte-opt.el")))) + "cconv.el" "byte-opt.el" "comp.el")))) (message "Reloading stale %s" (file-name-nondirectory f)) (condition-case nil (load f 'noerror nil 'nosuffix) commit 301cf0d27892f76b7967d7f71d48a1899c27d477 Merge: 65cc8efa33 7b15cc3ebb Author: Andrea Corallo Date: Thu Apr 23 08:41:15 2020 +0100 Merge remote-tracking branch 'savannah/master' into HEAD commit 65cc8efa333bbb66acd7b19f4b39c3138995e864 Author: Andrea Corallo Date: Thu Apr 16 19:03:54 2020 +0100 * lisp/emacs-lisp/comp.el (comp-never-optimize-functions): Better doc fix diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 2cc7dfd17f..7486e80749 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -91,8 +91,8 @@ This intended for debugging the compiler itself. ;; For user convenience yes-or-no-p) "Primitive functions for which we do not perform trampoline optimization. -This is especially usefull for primitives known to be advised if bootstrap is -performed at `comp-speed' > 0." +This is especially useful for primitives known to be advised or +redefined when compilation is performed at `comp-speed' > 0." :type 'list :group 'comp) commit d432cbeb27c1f0a2e59c6853b61ecba3615f645e Merge: 886ded1b70 0127118c25 Author: Andrea Corallo Date: Thu Apr 16 17:35:35 2020 +0100 Merge remote-tracking branch 'savannah/master' into HEAD commit 886ded1b70f24c52ee526f0c4a69ca06829fb2a3 Author: Andrea Corallo Date: Thu Apr 16 18:59:40 2020 +0100 * lisp/emacs-lisp/comp.el (comp-never-optimize-functions): Add yes-or-no-p diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 788ffb5b77..2cc7dfd17f 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -85,8 +85,11 @@ This intended for debugging the compiler itself. :group 'comp) (defcustom comp-never-optimize-functions - '(macroexpand scroll-down scroll-up narrow-to-region widen rename-buffer - make-indirect-buffer delete-file top-level abort-recursive-edit) + '(;; Mandatory for Emacs to be working correctly + macroexpand scroll-down scroll-up narrow-to-region widen rename-buffer + make-indirect-buffer delete-file top-level abort-recursive-edit + ;; For user convenience + yes-or-no-p) "Primitive functions for which we do not perform trampoline optimization. This is especially usefull for primitives known to be advised if bootstrap is performed at `comp-speed' > 0." commit c5ed3a72a8a70931ef9b0f9d69f73ff0fd40cadb Author: Andrea Corallo Date: Wed Apr 15 22:55:30 2020 +0100 * lisp/subr.el (eval-after-load): Make use of load-true-file-name bug#40638 diff --git a/lisp/subr.el b/lisp/subr.el index f7445d8c25..c8eb12760c 100644 --- a/lisp/subr.el +++ b/lisp/subr.el @@ -4600,10 +4600,10 @@ This function makes or adds to an entry on `after-load-alist'." ;; So add an indirection to make sure that `func' is really run ;; "after-load" in case the provide call happens early. (lambda () - (if (not load-file-name) + (if (not load-true-file-name) ;; Not being provided from a file, run func right now. (funcall func) - (let ((lfn load-file-name) + (let ((lfn load-true-file-name) ;; Don't use letrec, because equal (in ;; add/remove-hook) would get trapped in a cycle. (fun (make-symbol "eval-after-load-helper"))) commit 208a11d3f0ede17b29da45c2491b703b6942a764 Merge: 8db8c851ad 6bf79d65d3 Author: Andrea Corallo Date: Tue Apr 14 18:25:23 2020 +0100 Merge remote-tracking branch 'savannah/master' into HEAD commit 8db8c851ad1568d61ed50a4d087e6de2b475cf5f Author: Andrea Corallo Date: Tue Apr 14 19:58:41 2020 +0100 Always set `load-true-file-name' where `load-file-name' is set too. Fix bug#40620. * lisp/cus-dep.el (custom-make-dependencies): Set load-true-file-name. * lisp/emacs-lisp/package.el (package-quickstart-refresh): Likewise. * lisp/international/mule.el (load-with-code-conversion): Likewise. * lisp/loadup.el (load-true-file-name): Likewise. diff --git a/lisp/cus-dep.el b/lisp/cus-dep.el index fd307a5c04..e2c2ebe5f4 100644 --- a/lisp/cus-dep.el +++ b/lisp/cus-dep.el @@ -90,6 +90,7 @@ Usage: emacs -batch -l ./cus-dep.el -f custom-make-dependencies DIRS" (string-match "\\`\\(.*\\)\\.el\\'" file) (let ((name (or generated-autoload-load-name ; see bug#5277 (file-name-nondirectory (match-string 1 file)))) + (load-true-file-name file) (load-file-name file)) (if (save-excursion (re-search-forward diff --git a/lisp/emacs-lisp/autoload.el b/lisp/emacs-lisp/autoload.el index 6180bee2aa..d9a43c2329 100644 --- a/lisp/emacs-lisp/autoload.el +++ b/lisp/emacs-lisp/autoload.el @@ -167,7 +167,9 @@ expression, in which case we want to handle forms differently." define-inline cl-defun cl-defmacro cl-defgeneric cl-defstruct pcase-defmacro)) (macrop car) - (setq expand (let ((load-file-name file)) (macroexpand form))) + (setq expand (let ((load-true-file-name file) + (load-file-name file)) + (macroexpand form))) (memq (car expand) '(progn prog1 defalias))) (make-autoload expand file 'expansion)) ;Recurse on the expansion. diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index 4312ab9ca9..b33e4897a0 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -3965,7 +3965,8 @@ activations need to be changed, such as when `package-load-list' is modified." (let ((load-suffixes '(".el" ".elc"))) (locate-library (package--autoloads-file-name pkg)))) (pfile (prin1-to-string file))) - (insert "(let ((load-file-name " pfile "))\n") + (insert "(let ((load-true-file-name " pfile ")\ +(load-file-name " pfile "))\n") (insert-file-contents file) ;; Fixup the special #$ reader form and throw away comments. (while (re-search-forward "#\\$\\|^;\\(.*\n\\)" nil 'move) diff --git a/lisp/international/mule.el b/lisp/international/mule.el index 72e8cad9d6..363df13dfe 100644 --- a/lisp/international/mule.el +++ b/lisp/international/mule.el @@ -320,8 +320,9 @@ Return t if file exists." (when purify-flag (push (purecopy file) preloaded-file-list)) (unwind-protect - (let ((load-file-name fullname) - (set-auto-coding-for-load t) + (let ((load-true-file-name fullname) + (load-file-name fullname) + (set-auto-coding-for-load t) (inhibit-file-name-operation nil)) (with-current-buffer buffer ;; So that we don't get completely screwed if the diff --git a/lisp/loadup.el b/lisp/loadup.el index 3cc47bc91f..7cf2cb01c3 100644 --- a/lisp/loadup.el +++ b/lisp/loadup.el @@ -566,6 +566,7 @@ lost after dumping"))) ;; Don't keep `load-file-name' set during the top-level session! ;; Otherwise, it breaks a lot of code which does things like ;; (or load-file-name byte-compile-current-file). +(setq load-true-file-name nil) (setq load-file-name nil) (eval top-level) commit 8decfbe4d75b538707fa794c395d712bfde407f4 Author: Andrea Corallo Date: Tue Apr 14 08:48:24 2020 +0100 * lisp/emacs-lisp/comp.el (native-compile-async): Better error message. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index fda8f7dc78..788ffb5b77 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2311,13 +2311,14 @@ LOAD can be nil t or 'late." (list "Path not a file nor directory" path))))) (dolist (file files) (if-let ((entry (cl-find file comp-files-queue :key #'car :test #'string=))) - (when load - ;; When no load is specified (plain async compilation) we - ;; consider valid the one previously queued, otherwise we - ;; check for coherence (bug#40602). - (cl-assert (eq load (cdr entry)) - nil "Incoherent load kind in compilation queue for %s" - file)) + ;; When no load is specified (plain async compilation) we + ;; consider valid the one previously queued, otherwise we + ;; check for coherence (bug#40602). + (cl-assert (or (null load) + (eq load (cdr entry))) + nil "Trying to queue %s with LOAD %s but this is already \ +queued with LOAD %" + file load (cdr entry)) (setf comp-files-queue (append comp-files-queue `((,file . ,load)))))) (when (zerop (comp-async-runnings)) (comp-run-async-workers) commit b7678cf10e13727dab300c7162649cafc488e27e Author: Andrea Corallo Date: Mon Apr 13 20:43:21 2020 +0100 * lisp/emacs-lisp/comp.el (comp-finalize-relocs): Better commentary. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index a4764f91c3..fda8f7dc78 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2082,11 +2082,11 @@ Update all insn accordingly." (d-impure-idx (comp-data-container-idx d-impure)) (d-ephemeral (comp-ctxt-d-ephemeral comp-ctxt)) (d-ephemeral-idx (comp-data-container-idx d-ephemeral))) - ;; Remove things in d-impure that are already in d-default. + ;; Remove entries in d-impure already present in d-default. (cl-loop for obj being each hash-keys of d-impure-idx when (gethash obj d-default-idx) do (remhash obj d-impure-idx)) - ;; Remove things in d-ephemeral that are already in d-default or + ;; Remove entries in d-ephemeral already present in d-default or ;; d-impure. (cl-loop for obj being each hash-keys of d-ephemeral-idx when (or (gethash obj d-default-idx) (gethash obj d-impure-idx)) commit 9f42f35418c568ae22eca65ecec773ff40f2fc0e Author: Andrea Corallo Date: Mon Apr 13 20:39:15 2020 +0100 * Fix native-compile-async for bug#40602. * lisp/emacs-lisp/comp.el (native-compile-async): Relax coherency condition. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 9dc775bb6a..a4764f91c3 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2311,9 +2311,13 @@ LOAD can be nil t or 'late." (list "Path not a file nor directory" path))))) (dolist (file files) (if-let ((entry (cl-find file comp-files-queue :key #'car :test #'string=))) - (cl-assert (eq load (cdr entry)) - nil "Incoherent load kind in compilation queue for %s" - file) + (when load + ;; When no load is specified (plain async compilation) we + ;; consider valid the one previously queued, otherwise we + ;; check for coherence (bug#40602). + (cl-assert (eq load (cdr entry)) + nil "Incoherent load kind in compilation queue for %s" + file)) (setf comp-files-queue (append comp-files-queue `((,file . ,load)))))) (when (zerop (comp-async-runnings)) (comp-run-async-workers) commit 517c123fd4b250b570ce6f47ead4c14eac41ab8c Merge: 9787323552 cdbb37f628 Author: Andrea Corallo Date: Mon Apr 13 18:11:12 2020 +0100 Merge remote-tracking branch 'savannah/master' into HEAD commit 97873235523dd6fc236b3ebc7bf34a53fb5a528a Author: Andrea Corallo Date: Mon Apr 13 16:57:27 2020 +0100 * src/lread.c (Fload): Clean-up unnecessary sanity check. 'is_native_elisp' can't be non zero if NATIVE_COMP_FLAG is not set. diff --git a/src/lread.c b/src/lread.c index 9bd60b9b38..1e05ac6932 100644 --- a/src/lread.c +++ b/src/lread.c @@ -1506,22 +1506,16 @@ Return t if the file exists and loads successfully. */) } else if (is_native_elisp) { - if (NATIVE_COMP_FLAG) + specbind (Qcurrent_load_list, Qnil); + if (!NILP (Vpurify_flag)) { - specbind (Qcurrent_load_list, Qnil); - if (!NILP (Vpurify_flag)) - { - Lisp_Object base = parent_directory (Ffile_name_directory (found)); - Lisp_Object offset = Flength (base); - hist_file_name = Fsubstring (found, offset, Qnil); - } - LOADHIST_ATTACH (hist_file_name); - Fnative_elisp_load (found, Qnil); - build_load_history (hist_file_name, true); + Lisp_Object base = parent_directory (Ffile_name_directory (found)); + Lisp_Object offset = Flength (base); + hist_file_name = Fsubstring (found, offset, Qnil); } - else - /* This cannot happen. */ - emacs_abort (); + LOADHIST_ATTACH (hist_file_name); + Fnative_elisp_load (found, Qnil); + build_load_history (hist_file_name, true); } else { commit 05adf0353faf0bff3da60230a691b381de297843 Author: Andrea Corallo Date: Mon Apr 13 16:54:03 2020 +0100 Fix function find mechanism for installed instance. * src/lread.c (parent_directory): New function. (Fload): Make use of 'parent_directory' and fix load-history build-up with relative paths. diff --git a/src/lread.c b/src/lread.c index 18a56d0969..9bd60b9b38 100644 --- a/src/lread.c +++ b/src/lread.c @@ -1102,6 +1102,14 @@ close_infile_unwind (void *arg) infile = prev_infile; } +static Lisp_Object +parent_directory (Lisp_Object directory) +{ + return Ffile_name_directory (Fsubstring (directory, + make_fixnum (0), + Fsub1 (Flength (directory)))); +} + DEFUN ("load", Fload, Sload, 1, 5, 0, doc: /* Execute a file of Lisp code named FILE. First try FILE with `.elc' appended, then try with `.el', then try @@ -1474,13 +1482,8 @@ Return t if the file exists and loads successfully. */) same folder of their respective sources therfore not to break packages we fake `load-file-name' here. The non faked version of it is `load-true-file-name'. */ - Lisp_Object dir = Ffile_name_directory (found); - Lisp_Object parent_dir = - Ffile_name_directory (Fsubstring (dir, - make_fixnum (0), - Fsub1 (Flength (dir)))); specbind (Qload_file_name, - concat2 (parent_dir, + concat2 (parent_directory (Ffile_name_directory (found)), Ffile_name_nondirectory (found))); } else @@ -1506,9 +1509,15 @@ Return t if the file exists and loads successfully. */) if (NATIVE_COMP_FLAG) { specbind (Qcurrent_load_list, Qnil); - LOADHIST_ATTACH (found); + if (!NILP (Vpurify_flag)) + { + Lisp_Object base = parent_directory (Ffile_name_directory (found)); + Lisp_Object offset = Flength (base); + hist_file_name = Fsubstring (found, offset, Qnil); + } + LOADHIST_ATTACH (hist_file_name); Fnative_elisp_load (found, Qnil); - build_load_history (found, true); + build_load_history (hist_file_name, true); } else /* This cannot happen. */ commit 1c5548f1c51b44b78d05deb11a31b8678df7b4e7 Author: Andrea Corallo Date: Mon Apr 13 11:07:11 2020 +0100 * src/lread.c (Fload): Add comment. diff --git a/src/lread.c b/src/lread.c index 937b456685..18a56d0969 100644 --- a/src/lread.c +++ b/src/lread.c @@ -1469,6 +1469,11 @@ Return t if the file exists and loads successfully. */) if (is_native_elisp) { + /* Many packages use `load-file-name' as a way to obtain the + package location (see bug#40099). .eln files are not in the + same folder of their respective sources therfore not to break + packages we fake `load-file-name' here. The non faked + version of it is `load-true-file-name'. */ Lisp_Object dir = Ffile_name_directory (found); Lisp_Object parent_dir = Ffile_name_directory (Fsubstring (dir, commit 3effa2d674691b069cefd978187100911296f738 Merge: c8b7e07553 c395ebaf21 Author: Andrea Corallo Date: Mon Apr 13 10:55:51 2020 +0100 Merge remote-tracking branch 'savannah/master' into HEAD commit c8b7e07553a77d9c57e2022a06c651513109ea5d Author: Andrea Corallo Date: Sun Apr 12 22:17:08 2020 +0100 Revert "Fix org for eln new compilation folder layout" This reverts commit f77f6ca77054ca6122df2742345710b7493ad293. diff --git a/lisp/org/org.el b/lisp/org/org.el index a9303e880b..f1a7f61a9a 100644 --- a/lisp/org/org.el +++ b/lisp/org/org.el @@ -78,10 +78,8 @@ (or (eq this-command 'eval-buffer) (condition-case nil - (load (expand-file-name "org-loaddefs.el" - (if (string-match "[.]eln$" load-file-name) - (concat (file-name-directory load-file-name) "..") - (file-name-directory load-file-name))) + (load (concat (file-name-directory load-file-name) + "org-loaddefs.el") nil t t t) (error (message "WARNING: No org-loaddefs.el file could be found from where org.el is loaded.") commit 6e09597e27fd769e734ddacca8824abd6769257d Author: Andrea Corallo Date: Sun Apr 12 21:15:52 2020 +0100 Introduce load-true-file-name * src/comp.c (maybe_defer_native_compilation): Use `load-true-file-name' instead of `load-file-name'. * src/lread.c (Fload, end_of_file_error, read1, read_list) (init_lread, syms_of_lread): Add new `load-true-file-name' and fake `load-file-name' value when loading .eln files. diff --git a/src/comp.c b/src/comp.c index 32fc7f23c4..4bd271402c 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3467,7 +3467,7 @@ maybe_defer_native_compilation (Lisp_Object function_name, #include #include if (!NILP (function_name) && - STRINGP (Vload_file_name)) + STRINGP (Vload_true_file_name)) { static FILE *f; if (!f) @@ -3480,7 +3480,7 @@ maybe_defer_native_compilation (Lisp_Object function_name, exit (1); fprintf (f, "function %s file %s\n", SSDATA (Fsymbol_name (function_name)), - SSDATA (Vload_file_name)); + SSDATA (Vload_true_file_name)); fflush (f); } #endif @@ -3489,12 +3489,12 @@ maybe_defer_native_compilation (Lisp_Object function_name, || !NILP (Vpurify_flag) || !COMPILEDP (definition) || !FIXNUMP (AREF (definition, COMPILED_ARGLIST)) - || !STRINGP (Vload_file_name) - || !suffix_p (Vload_file_name, ".elc")) + || !STRINGP (Vload_true_file_name) + || !suffix_p (Vload_true_file_name, ".elc")) return; Lisp_Object src = - concat2 (CALL1I (file-name-sans-extension, Vload_file_name), + concat2 (CALL1I (file-name-sans-extension, Vload_true_file_name), build_pure_c_string (".el")); if (NILP (Ffile_exists_p (src))) return; diff --git a/src/lread.c b/src/lread.c index 2b1ac93aa9..937b456685 100644 --- a/src/lread.c +++ b/src/lread.c @@ -1467,7 +1467,20 @@ Return t if the file exists and loads successfully. */) message_with_string ("Loading %s...", file, 1); } - specbind (Qload_file_name, found); + if (is_native_elisp) + { + Lisp_Object dir = Ffile_name_directory (found); + Lisp_Object parent_dir = + Ffile_name_directory (Fsubstring (dir, + make_fixnum (0), + Fsub1 (Flength (dir)))); + specbind (Qload_file_name, + concat2 (parent_dir, + Ffile_name_nondirectory (found))); + } + else + specbind (Qload_file_name, found); + specbind (Qload_true_file_name, found); specbind (Qinhibit_file_name_operation, Qnil); specbind (Qload_in_progress, Qt); @@ -1928,8 +1941,8 @@ readevalloop_1 (int old) static AVOID end_of_file_error (void) { - if (STRINGP (Vload_file_name)) - xsignal1 (Qend_of_file, Vload_file_name); + if (STRINGP (Vload_true_file_name)) + xsignal1 (Qend_of_file, Vload_true_file_name); xsignal0 (Qend_of_file); } @@ -3161,7 +3174,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list) goto retry; } if (c == '$') - return Vload_file_name; + return Vload_true_file_name; if (c == '\'') return list2 (Qfunction, read0 (readcharfun)); /* #:foo is the uninterned symbol named foo. */ @@ -3960,7 +3973,7 @@ read_list (bool flag, Lisp_Object readcharfun) first_in_list = 0; /* While building, if the list starts with #$, treat it specially. */ - if (EQ (elt, Vload_file_name) + if (EQ (elt, Vload_true_file_name) && ! NILP (elt) && !NILP (Vpurify_flag)) { @@ -3981,7 +3994,7 @@ read_list (bool flag, Lisp_Object readcharfun) elt = concat2 (dot_dot_lisp, Ffile_name_nondirectory (elt)); } } - else if (EQ (elt, Vload_file_name) + else if (EQ (elt, Vload_true_file_name) && ! NILP (elt) && load_force_doc_strings) doc_reference = 2; @@ -4737,6 +4750,7 @@ init_lread (void) load_in_progress = 0; Vload_file_name = Qnil; + Vload_true_file_name = Qnil; Vstandard_input = Qt; Vloads_in_progress = Qnil; } @@ -4938,9 +4952,15 @@ directory. These file names are converted to absolute at startup. */); Vload_history = Qnil; DEFVAR_LISP ("load-file-name", Vload_file_name, - doc: /* Full name of file being loaded by `load'. */); + doc: /* Full name of file being loaded by `load'. +In case a .eln file is being loaded this is unreliable and `load-true-file-name' +should be used instead. */); Vload_file_name = Qnil; + DEFVAR_LISP ("load-true-file-name", Vload_true_file_name, + doc: /* Full name of file being loaded by `load'. */); + Vload_true_file_name = Qnil; + DEFVAR_LISP ("user-init-file", Vuser_init_file, doc: /* File name, including directory, of user's initialization file. If the file loaded had extension `.elc', and the corresponding source file @@ -5082,6 +5102,7 @@ that are loaded before your customizations are read! */); DEFSYM (Qfunction, "function"); DEFSYM (Qload, "load"); DEFSYM (Qload_file_name, "load-file-name"); + DEFSYM (Qload_true_file_name, "load-true-file-name"); DEFSYM (Qeval_buffer_list, "eval-buffer-list"); DEFSYM (Qdir_ok, "dir-ok"); DEFSYM (Qdo_after_load_evaluation, "do-after-load-evaluation"); commit f9a1d4b3f744cec00286fb211edaa0127e361061 Merge: b56de5dda2 aed427ece5 Author: Andrea Corallo Date: Sun Apr 12 16:53:36 2020 +0100 Merge remote-tracking branch 'savannah/master' into HEAD commit b56de5dda235599c0dcb26c9d4936aaf8be46db3 Author: Andrea Corallo Date: Sun Apr 12 13:06:14 2020 +0100 * src/pdumper.c (dump_do_dump_relocation): Optimize native dump load. Check just once if is a local build or Emacs got installed. diff --git a/src/pdumper.c b/src/pdumper.c index 490f357219..bf6bc3a3bc 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -5296,15 +5296,25 @@ dump_do_dump_relocation (const uintptr_t dump_base, #ifdef HAVE_NATIVE_COMP case RELOC_NATIVE_COMP_UNIT: { + static enum { UNKNOWN, LOCAL_BUILD, INSTALLED } installation_state; struct Lisp_Native_Comp_Unit *comp_u = dump_ptr (dump_base, reloc_offset); + if (!CONSP (comp_u->file)) error ("Trying to load incoherent dumped .eln"); + + if (installation_state == UNKNOWN) + /* Check just once if is a local build or Emacs got installed. */ + installation_state = + NILP (Ffile_exists_p (concat2 (Vinvocation_directory, + XCAR (comp_u->file)))) + ? LOCAL_BUILD : INSTALLED; + comp_u->file = - NILP (Ffile_exists_p (XCAR (comp_u->file))) - ? XCDR (comp_u->file) : XCAR (comp_u->file); - comp_u->handle = - dynlib_open (SSDATA (concat2 (Vinvocation_directory, comp_u->file))); + concat2 (Vinvocation_directory, + installation_state == LOCAL_BUILD + ? XCDR (comp_u->file) : XCAR (comp_u->file)); + comp_u->handle = dynlib_open (SSDATA (comp_u->file)); if (!comp_u->handle) error ("%s", dynlib_error ()); load_comp_unit (comp_u, true, false); commit 3dd6cf813953ffda1a581243faa098f3b8f7c12b Author: Andrea Corallo Date: Sat Apr 11 13:59:59 2020 +0100 Implement working make install for native build. diff --git a/Makefile.in b/Makefile.in index 67e15cfecd..2f6a68fd9d 100644 --- a/Makefile.in +++ b/Makefile.in @@ -421,7 +421,8 @@ lib lib-src lisp nt: Makefile dirstate = .git/logs/HEAD VCSWITNESS = $(if $(wildcard $(srcdir)/$(dirstate)),$$(srcdir)/../$(dirstate)) src: Makefile - $(MAKE) -C $@ VCSWITNESS='$(VCSWITNESS)' all + $(MAKE) -C $@ VCSWITNESS='$(VCSWITNESS)' BIN_DESTDIR='$(DESTDIR)${bindir}/' \ + LISP_DESTDIR='$(DESTDIR)${lispdir}/' all blessmail: Makefile src $(MAKE) -C lib-src maybe-blessmail diff --git a/lisp/loadup.el b/lisp/loadup.el index bda9919cbb..3cc47bc91f 100644 --- a/lisp/loadup.el +++ b/lisp/loadup.el @@ -449,19 +449,32 @@ lost after dumping"))) ;; At this point, we're ready to resume undo recording for scratch. (buffer-enable-undo "*scratch*") -(when (boundp 'comp-ctxt) ; FIXME better native-comp build discriminant? - ;; Set the filename for every compilation unit as realtive - ;; to obtain a position independent dump. - (let ((h (make-hash-table :test #'eq))) +(when (boundp 'comp-ctxt) ; FIXME better native-comp feature discriminant? + ;; Fix the compilation unit filename to have it working when + ;; when installed or if the source directory got moved. This is set to be + ;; a pair in the form: (rel-path-from-install-bin . rel-path-from-local-bin). + (let ((h (make-hash-table :test #'eq)) + (lisp-src-dir (expand-file-name (concat default-directory "../lisp"))) + (bin-dest-dir (cadr (member "--bin-dest" command-line-args))) + (lisp-dest-dir (cadr (member "--lisp-dest" command-line-args)))) (mapatoms (lambda (s) (let ((f (symbol-function s))) (when (subr-native-elisp-p f) (puthash (subr-native-comp-unit f) nil h))))) (maphash (lambda (cu _) - (native-comp-unit-set-file + (native-comp-unit-set-file cu - (file-relative-name (native-comp-unit-file cu) - invocation-directory))) + (cons + ;; Relative path from the installed binary. + (file-relative-name + (concat lisp-dest-dir + (replace-regexp-in-string + (regexp-quote lisp-src-dir) "" + (native-comp-unit-file cu))) + bin-dest-dir) + ;; Relative path from the built uninstalled binary. + (file-relative-name (native-comp-unit-file cu) + invocation-directory)))) h))) (when (hash-table-p purify-flag) diff --git a/src/Makefile.in b/src/Makefile.in index 429f703544..7f86e96cdb 100644 --- a/src/Makefile.in +++ b/src/Makefile.in @@ -588,7 +588,8 @@ endif ifeq ($(DUMPING),pdumper) $(pdmp): emacs$(EXEEXT) - LC_ALL=C $(RUN_TEMACS) -batch $(BUILD_DETAILS) -l loadup --temacs=pdump + LC_ALL=C $(RUN_TEMACS) -batch $(BUILD_DETAILS) -l loadup --temacs=pdump \ + --bin-dest $(BIN_DESTDIR) --lisp-dest $(LISP_DESTDIR) cp -f $@ $(bootstrap_pdmp) endif diff --git a/src/pdumper.c b/src/pdumper.c index 69594b51c5..490f357219 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -5298,6 +5298,11 @@ dump_do_dump_relocation (const uintptr_t dump_base, { struct Lisp_Native_Comp_Unit *comp_u = dump_ptr (dump_base, reloc_offset); + if (!CONSP (comp_u->file)) + error ("Trying to load incoherent dumped .eln"); + comp_u->file = + NILP (Ffile_exists_p (XCAR (comp_u->file))) + ? XCDR (comp_u->file) : XCAR (comp_u->file); comp_u->handle = dynlib_open (SSDATA (concat2 (Vinvocation_directory, comp_u->file))); if (!comp_u->handle) commit 7f5d1e9aa8e3ad27700dbce2b8951ffde1054aaf Author: Andrea Corallo Date: Sun Apr 12 12:38:46 2020 +0100 Set invocation variables during dump load. Vinvocation_directory must be set during dump load process to support .eln load. * src/pdumper.h: (pdumper_load): Add argv0 and original_pwd parameters. * src/pdumper.c (pdumper_load): Add argv0 and original_pwd parameter plus call 'set_invocation_vars'. * src/lisp.h (set_invocation_vars): New function. * src/emacs.c (set_invocation_vars): New function. (init_cmdargs): Move logic into 'set_invocation_vars' and call it. (load_pdump): Add 'original_pwd' parameter and update calls to 'pdumper_load'. (main): Set emacs_wd earlier and update call to 'pdumper_load'. diff --git a/src/emacs.c b/src/emacs.c index fcc02a3a87..2c90825742 100644 --- a/src/emacs.c +++ b/src/emacs.c @@ -403,34 +403,35 @@ terminate_due_to_signal (int sig, int backtrace_limit) /* This shouldn't be executed, but it prevents a warning. */ exit (1); } - -/* Code for dealing with Lisp access to the Unix command line. */ -static void -init_cmdargs (int argc, char **argv, int skip_args, char const *original_pwd) +/* Set `invocation-name' `invocation-directory'. */ + +void +set_invocation_vars (char *argv0, char const *original_pwd) { - int i; - Lisp_Object name, dir, handler; - ptrdiff_t count = SPECPDL_INDEX (); - Lisp_Object raw_name; + /* This function can be called from within pdumper or later during + boot. No need to run it twice. */ + static bool double_run_guard; + if (double_run_guard) + return; + double_run_guard = true; + + Lisp_Object raw_name, handler; AUTO_STRING (slash_colon, "/:"); - initial_argv = argv; - initial_argc = argc; - #ifdef WINDOWSNT - /* Must use argv[0] converted to UTF-8, as it begets many standard + /* Must use argv0 converted to UTF-8, as it begets many standard file and directory names. */ { - char argv0[MAX_UTF8_PATH]; + char argv0_1[MAX_UTF8_PATH]; - if (filename_from_ansi (argv[0], argv0) == 0) - raw_name = build_unibyte_string (argv0); + if (filename_from_ansi (argv0, argv0_1) == 0) + raw_name = build_unibyte_string (argv0_1); else - raw_name = build_unibyte_string (argv[0]); + raw_name = build_unibyte_string (argv0); } #else - raw_name = build_unibyte_string (argv[0]); + raw_name = build_unibyte_string (argv0); #endif /* Add /: to the front of the name @@ -442,7 +443,7 @@ init_cmdargs (int argc, char **argv, int skip_args, char const *original_pwd) Vinvocation_name = Ffile_name_nondirectory (raw_name); Vinvocation_directory = Ffile_name_directory (raw_name); - /* If we got no directory in argv[0], search PATH to find where + /* If we got no directory in argv0, search PATH to find where Emacs actually came from. */ if (NILP (Vinvocation_directory)) { @@ -470,6 +471,21 @@ init_cmdargs (int argc, char **argv, int skip_args, char const *original_pwd) Vinvocation_directory = Fexpand_file_name (Vinvocation_directory, odir); } +} + + +/* Code for dealing with Lisp access to the Unix command line. */ +static void +init_cmdargs (int argc, char **argv, int skip_args, char const *original_pwd) +{ + int i; + Lisp_Object name, dir; + ptrdiff_t count = SPECPDL_INDEX (); + + initial_argv = argv; + initial_argc = argc; + + set_invocation_vars (argv[0], original_pwd); Vinstallation_directory = Qnil; @@ -758,7 +774,7 @@ load_pdump_find_executable (char const *argv0, ptrdiff_t *candidate_size) } static void -load_pdump (int argc, char **argv) +load_pdump (int argc, char **argv, char const *original_pwd) { const char *const suffix = ".pdmp"; int result; @@ -793,7 +809,7 @@ load_pdump (int argc, char **argv) if (dump_file) { - result = pdumper_load (dump_file); + result = pdumper_load (dump_file, argv[0], original_pwd); if (result != PDUMPER_LOAD_SUCCESS) fatal ("could not load dump file \"%s\": %s", @@ -842,7 +858,7 @@ load_pdump (int argc, char **argv) if (bufsize < needed) dump_file = xpalloc (dump_file, &bufsize, needed - bufsize, -1, 1); strcpy (dump_file + exenamelen, suffix); - result = pdumper_load (dump_file); + result = pdumper_load (dump_file, argv[0], original_pwd); if (result == PDUMPER_LOAD_SUCCESS) goto out; @@ -873,7 +889,7 @@ load_pdump (int argc, char **argv) } sprintf (dump_file, "%s%c%s%s", path_exec, DIRECTORY_SEP, argv0_base, suffix); - result = pdumper_load (dump_file); + result = pdumper_load (dump_file, argv[0], original_pwd); if (result == PDUMPER_LOAD_FILE_NOT_FOUND) { @@ -908,7 +924,7 @@ load_pdump (int argc, char **argv) #endif sprintf (dump_file, "%s%c%s%s", path_exec, DIRECTORY_SEP, argv0_base, suffix); - result = pdumper_load (dump_file); + result = pdumper_load (dump_file, argv[0], original_pwd); } if (result != PDUMPER_LOAD_SUCCESS) @@ -929,7 +945,6 @@ main (int argc, char **argv) /* Variable near the bottom of the stack, and aligned appropriately for pointers. */ void *stack_bottom_variable; - bool no_loadup = false; char *junk = 0; char *dname_arg = 0; @@ -1048,9 +1063,10 @@ main (int argc, char **argv) w32_init_main_thread (); #endif + emacs_wd = emacs_get_current_dir_name (); #ifdef HAVE_PDUMPER if (attempt_load_pdump) - load_pdump (argc, argv); + load_pdump (argc, argv, emacs_wd); #endif argc = maybe_disable_address_randomization (argc, argv); @@ -1122,7 +1138,6 @@ main (int argc, char **argv) exit (0); } - emacs_wd = emacs_get_current_dir_name (); #ifdef HAVE_PDUMPER if (dumped_with_pdumper_p ()) pdumper_record_wd (emacs_wd); diff --git a/src/lisp.h b/src/lisp.h index 9eccbd2f79..5456b9cce8 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -4423,6 +4423,7 @@ extern bool display_arg; extern Lisp_Object decode_env_path (const char *, const char *, bool); extern Lisp_Object empty_unibyte_string, empty_multibyte_string; extern AVOID terminate_due_to_signal (int, int); +extern void set_invocation_vars (char *argv0, char const *original_pwd); #ifdef WINDOWSNT extern Lisp_Object Vlibrary_cache; #endif diff --git a/src/pdumper.c b/src/pdumper.c index 7fbacfe4a1..69594b51c5 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -5428,7 +5428,7 @@ enum dump_section N.B. We run very early in initialization, so we can't use lisp, unwinding, xmalloc, and so on. */ int -pdumper_load (const char *dump_filename) +pdumper_load (const char *dump_filename, char *argv0, char const *original_pwd) { intptr_t dump_size; struct stat stat; @@ -5574,6 +5574,9 @@ pdumper_load (const char *dump_filename) for (int i = 0; i < nr_dump_hooks; ++i) dump_hooks[i] (); + /* Once we can allocate and before loading .eln files we must set + Vinvocation_directory (.eln paths are relative to it). */ + set_invocation_vars (argv0, original_pwd); dump_do_all_dump_reloc_for_phase (header, dump_base, LATE_RELOCS); dump_do_all_dump_reloc_for_phase (header, dump_base, VERY_LATE_RELOCS); initialized = true; diff --git a/src/pdumper.h b/src/pdumper.h index 6a99b511f2..b92958e12b 100644 --- a/src/pdumper.h +++ b/src/pdumper.h @@ -127,7 +127,8 @@ enum pdumper_load_result PDUMPER_LOAD_ERROR /* Must be last, as errno may be added. */ }; -int pdumper_load (const char *dump_filename); +int pdumper_load (const char *dump_filename, char *argv0, + char const *original_pwd); struct pdumper_loaded_dump { commit f4156b452fd45ed4a706a2083755212c16ef88bb Author: Andrea Corallo Date: Fri Apr 10 22:30:34 2020 +0100 Implement position independent dump. Set the filename for every compilation unit as realtive to obtain a position independent dump. * lisp/loadup.el: Modify filename for every compilation unit as position independent. * src/pdumper.c (dump_do_dump_relocation): Update to be invocation directory relative. diff --git a/lisp/loadup.el b/lisp/loadup.el index 97525b2708..bda9919cbb 100644 --- a/lisp/loadup.el +++ b/lisp/loadup.el @@ -449,6 +449,21 @@ lost after dumping"))) ;; At this point, we're ready to resume undo recording for scratch. (buffer-enable-undo "*scratch*") +(when (boundp 'comp-ctxt) ; FIXME better native-comp build discriminant? + ;; Set the filename for every compilation unit as realtive + ;; to obtain a position independent dump. + (let ((h (make-hash-table :test #'eq))) + (mapatoms (lambda (s) + (let ((f (symbol-function s))) + (when (subr-native-elisp-p f) + (puthash (subr-native-comp-unit f) nil h))))) + (maphash (lambda (cu _) + (native-comp-unit-set-file + cu + (file-relative-name (native-comp-unit-file cu) + invocation-directory))) + h))) + (when (hash-table-p purify-flag) (let ((strings 0) (vectors 0) diff --git a/src/pdumper.c b/src/pdumper.c index 03c31681cd..7fbacfe4a1 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -5298,7 +5298,8 @@ dump_do_dump_relocation (const uintptr_t dump_base, { struct Lisp_Native_Comp_Unit *comp_u = dump_ptr (dump_base, reloc_offset); - comp_u->handle = dynlib_open (SSDATA (comp_u->file)); + comp_u->handle = + dynlib_open (SSDATA (concat2 (Vinvocation_directory, comp_u->file))); if (!comp_u->handle) error ("%s", dynlib_error ()); load_comp_unit (comp_u, true, false); commit d85b803b78bc2a9b0424f0caac62a4e9de49b3e4 Author: Andrea Corallo Date: Fri Apr 10 22:24:07 2020 +0100 * src/comp.c (native-comp-unit-set-file): New function. diff --git a/src/data.c b/src/data.c index 2040e4eaec..1809d58c2c 100644 --- a/src/data.c +++ b/src/data.c @@ -884,9 +884,19 @@ DEFUN ("native-comp-unit-file", Fnative_comp_unit_file, Snative_comp_unit_file, 1, 1, 0, doc: /* Return the file of the native compilation unit. */) (Lisp_Object comp_unit) +{ + CHECK_TYPE (NATIVE_COMP_UNITP (comp_unit), Qnative_comp_unit, comp_unit); + return XNATIVE_COMP_UNIT (comp_unit)->file; +} + +DEFUN ("native-comp-unit-set-file", Fnative_comp_unit_set_file, + Snative_comp_unit_set_file, 2, 2, 0, + doc: /* Return the file of the native compilation unit. */) + (Lisp_Object comp_unit, Lisp_Object new_file) { CHECK_TYPE (NATIVE_COMP_UNITP (comp_unit), Qnative_comp_unit, comp_unit); XNATIVE_COMP_UNIT (comp_unit)->file = new_file; + return comp_unit; } #endif @@ -4007,6 +4017,7 @@ syms_of_data (void) defsubr (&Ssubr_native_elisp_p); defsubr (&Ssubr_native_comp_unit); defsubr (&Snative_comp_unit_file); + defsubr (&Snative_comp_unit_set_file); #endif #ifdef HAVE_MODULES defsubr (&Suser_ptrp); commit 62f956970f5fe4b180ca57b290594530386d8b02 Author: Andrea Corallo Date: Mon Apr 6 18:03:34 2020 +0100 * src/comp.c (native-comp-unit-file): Better parameter name. diff --git a/src/data.c b/src/data.c index b53b8409b5..2040e4eaec 100644 --- a/src/data.c +++ b/src/data.c @@ -883,11 +883,12 @@ DEFUN ("subr-native-comp-unit", Fsubr_native_comp_unit, DEFUN ("native-comp-unit-file", Fnative_comp_unit_file, Snative_comp_unit_file, 1, 1, 0, doc: /* Return the file of the native compilation unit. */) - (Lisp_Object object) + (Lisp_Object comp_unit) { - CHECK_TYPE (NATIVE_COMP_UNITP (object), Qnative_comp_unit, object); - return XNATIVE_COMP_UNIT (object)->file; + CHECK_TYPE (NATIVE_COMP_UNITP (comp_unit), Qnative_comp_unit, comp_unit); + XNATIVE_COMP_UNIT (comp_unit)->file = new_file; } + #endif DEFUN ("interactive-form", Finteractive_form, Sinteractive_form, 1, 1, 0, commit 4abb8c822ce02cf33712bd2699c5b77a5db49e31 Merge: 32a079aef2 3dc2f50e5b Author: Andrea Corallo Date: Mon Apr 6 18:06:29 2020 +0100 Merge remote-tracking branch 'savannah/master' into HEAD commit 32a079aef290fdc8913c1ce4e8910e63e6ff6dcc Author: Andrea Corallo Date: Mon Apr 6 20:03:34 2020 +0100 * lisp/emacs-lisp/comp.el (comp-c-func-name): Fix for M-x disassemble diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 3f4dba6b1f..9dc775bb6a 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -474,14 +474,18 @@ Put PREFIX in front of it." "-" "_" orig-name)) (human-readable (replace-regexp-in-string (rx (not (any "0-9a-z_"))) "" human-readable))) - ;; Prevent C namespace conflicts. - (cl-loop - with h = (comp-ctxt-funcs-h comp-ctxt) - for i from 0 - for c-sym = (concat prefix crypted "_" human-readable "_" - (number-to-string i)) - unless (gethash c-sym h) - return c-sym))) + (if comp-ctxt + ;; Prevent C namespace conflicts. + (cl-loop + with h = (comp-ctxt-funcs-h comp-ctxt) + for i from 0 + for c-sym = (concat prefix crypted "_" human-readable "_" + (number-to-string i)) + unless (gethash c-sym h) + return c-sym) + ;; When called out of a compilation context (ex disassembling) + ;; pick the first one. + (concat prefix crypted "_" human-readable "_0")))) (defun comp-decrypt-arg-list (x function-name) "Decript argument list X for FUNCTION-NAME." commit a04c960a358811b598434c62528d2cac8a2a1cb7 Author: Andrea Corallo Date: Mon Apr 6 19:04:43 2020 +0100 * src/comp.c (emit_FIXNUMP): Don't emit a shift when unnecessary. diff --git a/src/comp.c b/src/comp.c index 0a803545e5..32fc7f23c4 100644 --- a/src/comp.c +++ b/src/comp.c @@ -936,13 +936,14 @@ emit_FIXNUMP (gcc_jit_rvalue *obj) emit_comment ("FIXNUMP"); gcc_jit_rvalue *sh_res = - emit_binary_op ( - GCC_JIT_BINARY_OP_RSHIFT, - comp.emacs_int_type, - emit_XLI (obj), - gcc_jit_context_new_rvalue_from_int (comp.ctxt, - comp.emacs_int_type, - (USE_LSB_TAG ? 0 : FIXNUM_BITS))); + USE_LSB_TAG ? obj + : emit_binary_op (GCC_JIT_BINARY_OP_RSHIFT, + comp.emacs_int_type, + emit_XLI (obj), + gcc_jit_context_new_rvalue_from_int ( + comp.ctxt, + comp.emacs_int_type, + FIXNUM_BITS)); gcc_jit_rvalue *minus_res = emit_binary_op ( commit 3608623eba9870aff8b5eb842fb8ae10f092c6bb Merge: 4263f2fd15 95a7c6ec58 Author: Andrea Corallo Date: Sun Apr 5 22:08:17 2020 +0100 Merge remote-tracking branch 'savannah/master' into HEAD commit 4263f2fd15e8439b8e8676ebeb6ab2f7f9339025 Author: Andrea Corallo Date: Sun Apr 5 20:42:49 2020 +0100 * src/comp.c (emit_XFIXNUM): Fix for LSB_TAG plus annotate a FIXME. diff --git a/src/comp.c b/src/comp.c index 44de1f5fbc..0a803545e5 100644 --- a/src/comp.c +++ b/src/comp.c @@ -985,16 +985,19 @@ emit_XFIXNUM (gcc_jit_rvalue *obj) i, comp.inttypebits); - return emit_binary_op (GCC_JIT_BINARY_OP_RSHIFT, - comp.emacs_int_type, - i, - comp.inttypebits); + return emit_coerce (comp.emacs_int_type, + emit_binary_op (GCC_JIT_BINARY_OP_RSHIFT, + comp.emacs_uint_type, + i, + comp.inttypebits)); } else - return emit_binary_op (GCC_JIT_BINARY_OP_LSHIFT, - comp.emacs_int_type, - i, - comp.inttypebits); + /* FIXME: Implementation dependent (wants arithmetic shift). */ + return emit_coerce (comp.emacs_int_type, + emit_binary_op (GCC_JIT_BINARY_OP_RSHIFT, + comp.emacs_int_type, + i, + comp.inttypebits)); } static gcc_jit_rvalue * commit 346d50989a446285d38d411f8f77350ba4af5222 Author: Andrea Corallo Date: Sun Apr 5 19:40:51 2020 +0100 * src/comp.c (emit_const_lisp_obj, emit_mvar_val): Fix. diff --git a/src/comp.c b/src/comp.c index 904869d99c..44de1f5fbc 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1098,10 +1098,19 @@ emit_const_lisp_obj (Lisp_Object obj) SSDATA (Fprin1_to_string (obj, Qnil)))); if (NIL_IS_ZERO && EQ (obj, Qnil)) - return emit_coerce (comp.lisp_obj_type, - gcc_jit_context_new_rvalue_from_ptr (comp.ctxt, - comp.void_ptr_type, - NULL)); + { + gcc_jit_rvalue *n; +#ifdef WIDE_EMACS_INT + eassert (NIL_IS_ZERO); + n = emit_rvalue_from_long_long (0); +#else + n = gcc_jit_context_new_rvalue_from_ptr (comp.ctxt, + comp.void_ptr_type, + NULL); +#endif + return emit_coerce (comp.lisp_obj_type, n); + } + imm_reloc_t reloc = obj_to_reloc (obj); return gcc_jit_lvalue_as_rvalue ( @@ -1319,12 +1328,15 @@ emit_mvar_val (Lisp_Object mvar) /* We can still emit directly objects that are self-contained in a word (read fixnums). */ emit_comment (SSDATA (Fprin1_to_string (constant, Qnil))); - gcc_jit_rvalue *word = - (sizeof (MOST_POSITIVE_FIXNUM) > sizeof (void *)) - ? emit_rvalue_from_long_long (constant) - : gcc_jit_context_new_rvalue_from_long (comp.ctxt, - comp.void_ptr_type, - constant); + gcc_jit_rvalue *word; +#ifdef WIDE_EMACS_INT + word = emit_rvalue_from_long_long (constant); +#else + word = + gcc_jit_context_new_rvalue_from_ptr (comp.ctxt, + comp.void_ptr_type, + constant); +#endif return emit_coerce (comp.lisp_obj_type, word); } /* Other const objects are fetched from the reloc array. */ commit 598380416cf5bb6bd0cae45ddb3bb03c74da21bb Author: Andrea Corallo Date: Sun Apr 5 16:55:09 2020 +0100 * src/comp.c (hash_native_abi): Fix assertion. diff --git a/src/comp.c b/src/comp.c index b56d0afaa3..904869d99c 100644 --- a/src/comp.c +++ b/src/comp.c @@ -258,7 +258,7 @@ hash_native_abi (void) hexbuf_digest (SSDATA (digest), SDATA (digest), SHA512_DIGEST_SIZE); /* Check runs once. */ - eassert (Vcomp_abi_hash); + eassert (NILP (Vcomp_abi_hash)); Vcomp_abi_hash = digest; /* If 10 characters are usually sufficient for git I guess 16 are fine for us here. */ commit 7009e8af055afcef85c30d8a3866689bd4e49a4a Author: Andrea Corallo Date: Sun Apr 5 15:40:01 2020 +0100 * src/comp.c (emit_binary_op): New function. Wrap gcc_jit_context_new_binary_op within emit_binary_op to make sure input type are coherent and save a slew of code. diff --git a/src/comp.c b/src/comp.c index 75a2534b2e..b56d0afaa3 100644 --- a/src/comp.c +++ b/src/comp.c @@ -635,6 +635,18 @@ emit_coerce (gcc_jit_type *new_type, gcc_jit_rvalue *obj) dest_field); } +static gcc_jit_rvalue * +emit_binary_op (enum gcc_jit_binary_op op, + gcc_jit_type *result_type, + gcc_jit_rvalue *a, gcc_jit_rvalue *b) +{ + /* FIXME Check here for possible UB. */ + return gcc_jit_context_new_binary_op (comp.ctxt, NULL, + op, + result_type, + emit_coerce (result_type, a), + emit_coerce (result_type, b)); +} /* Should come with libgccjit. */ @@ -673,20 +685,16 @@ emit_rvalue_from_long_long (long long n) return emit_coerce (comp.long_long_type, - gcc_jit_context_new_binary_op ( - comp.ctxt, - NULL, + emit_binary_op ( GCC_JIT_BINARY_OP_BITWISE_OR, comp.unsigned_long_long_type, - gcc_jit_context_new_binary_op ( - comp.ctxt, - NULL, - GCC_JIT_BINARY_OP_LSHIFT, - comp.unsigned_long_long_type, - high, - gcc_jit_context_new_rvalue_from_int (comp.ctxt, - comp.unsigned_long_long_type, - 32)), + emit_binary_op ( + GCC_JIT_BINARY_OP_LSHIFT, + comp.unsigned_long_long_type, + high, + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.unsigned_long_long_type, + 32)), low)); } @@ -726,25 +734,21 @@ emit_ptr_arithmetic (gcc_jit_rvalue *ptr, gcc_jit_type *ptr_type, emit_comment ("ptr_arithmetic"); gcc_jit_rvalue *offset = - gcc_jit_context_new_binary_op ( - comp.ctxt, - NULL, + emit_binary_op ( GCC_JIT_BINARY_OP_MULT, comp.uintptr_type, gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.uintptr_type, size_of_ptr_ref), - emit_coerce (comp.uintptr_type, i)); + i); return emit_coerce ( ptr_type, - gcc_jit_context_new_binary_op ( - comp.ctxt, - NULL, + emit_binary_op ( GCC_JIT_BINARY_OP_PLUS, comp.uintptr_type, - emit_coerce (comp.uintptr_type, ptr), + ptr, offset)); } @@ -792,9 +796,7 @@ emit_XUNTAG (gcc_jit_rvalue *a, gcc_jit_type *type, long long lisp_word_tag) #ifndef WIDE_EMACS_INT return emit_coerce ( gcc_jit_type_get_pointer (type), - gcc_jit_context_new_binary_op ( - comp.ctxt, - NULL, + emit_binary_op ( GCC_JIT_BINARY_OP_MINUS, comp.emacs_int_type, emit_XLI (a), @@ -805,15 +807,12 @@ emit_XUNTAG (gcc_jit_rvalue *a, gcc_jit_type *type, long long lisp_word_tag) #else return emit_coerce ( gcc_jit_type_get_pointer (type), - gcc_jit_context_new_binary_op ( - comp.ctxt, - NULL, - GCC_JIT_BINARY_OP_MINUS, - comp.unsigned_long_long_type, - /* FIXME Should be XLP. */ - emit_coerce (comp.unsigned_long_long_type, emit_XLI (a)), - emit_coerce (comp.unsigned_long_long_type, - emit_rvalue_from_long_long (lisp_word_tag)))); + emit_binary_op ( + GCC_JIT_BINARY_OP_MINUS, + comp.unsigned_long_long_type, + /* FIXME Should be XLP. */ + emit_XLI (a), + emit_rvalue_from_long_long (lisp_word_tag))); #endif } @@ -849,9 +848,7 @@ emit_TAGGEDP (gcc_jit_rvalue *obj, ptrdiff_t tag) emit_comment ("TAGGEDP"); gcc_jit_rvalue *sh_res = - gcc_jit_context_new_binary_op ( - comp.ctxt, - NULL, + emit_binary_op ( GCC_JIT_BINARY_OP_RSHIFT, comp.emacs_int_type, emit_XLI (obj), @@ -860,15 +857,14 @@ emit_TAGGEDP (gcc_jit_rvalue *obj, ptrdiff_t tag) (USE_LSB_TAG ? 0 : VALBITS))); gcc_jit_rvalue *minus_res = - gcc_jit_context_new_binary_op (comp.ctxt, - NULL, - GCC_JIT_BINARY_OP_MINUS, - comp.unsigned_type, - emit_coerce (comp.unsigned_type, sh_res), - gcc_jit_context_new_rvalue_from_int ( - comp.ctxt, - comp.unsigned_type, - tag)); + emit_binary_op ( + GCC_JIT_BINARY_OP_MINUS, + comp.unsigned_type, + sh_res, + gcc_jit_context_new_rvalue_from_int ( + comp.ctxt, + comp.unsigned_type, + tag)); gcc_jit_rvalue *res = gcc_jit_context_new_unary_op ( @@ -876,15 +872,14 @@ emit_TAGGEDP (gcc_jit_rvalue *obj, ptrdiff_t tag) NULL, GCC_JIT_UNARY_OP_LOGICAL_NEGATE, comp.int_type, - gcc_jit_context_new_binary_op (comp.ctxt, - NULL, - GCC_JIT_BINARY_OP_BITWISE_AND, - comp.unsigned_type, - minus_res, - gcc_jit_context_new_rvalue_from_int ( - comp.ctxt, - comp.unsigned_type, - ((1 << GCTYPEBITS) - 1)))); + emit_binary_op ( + GCC_JIT_BINARY_OP_BITWISE_AND, + comp.unsigned_type, + minus_res, + gcc_jit_context_new_rvalue_from_int ( + comp.ctxt, + comp.unsigned_type, + ((1 << GCTYPEBITS) - 1)))); return res; } @@ -941,9 +936,7 @@ emit_FIXNUMP (gcc_jit_rvalue *obj) emit_comment ("FIXNUMP"); gcc_jit_rvalue *sh_res = - gcc_jit_context_new_binary_op ( - comp.ctxt, - NULL, + emit_binary_op ( GCC_JIT_BINARY_OP_RSHIFT, comp.emacs_int_type, emit_XLI (obj), @@ -952,15 +945,14 @@ emit_FIXNUMP (gcc_jit_rvalue *obj) (USE_LSB_TAG ? 0 : FIXNUM_BITS))); gcc_jit_rvalue *minus_res = - gcc_jit_context_new_binary_op (comp.ctxt, - NULL, - GCC_JIT_BINARY_OP_MINUS, - comp.unsigned_type, - emit_coerce (comp.unsigned_type, sh_res), - gcc_jit_context_new_rvalue_from_int ( - comp.ctxt, - comp.unsigned_type, - (Lisp_Int0 >> !USE_LSB_TAG))); + emit_binary_op ( + GCC_JIT_BINARY_OP_MINUS, + comp.unsigned_type, + sh_res, + gcc_jit_context_new_rvalue_from_int ( + comp.ctxt, + comp.unsigned_type, + (Lisp_Int0 >> !USE_LSB_TAG))); gcc_jit_rvalue *res = gcc_jit_context_new_unary_op ( @@ -968,15 +960,14 @@ emit_FIXNUMP (gcc_jit_rvalue *obj) NULL, GCC_JIT_UNARY_OP_LOGICAL_NEGATE, comp.int_type, - gcc_jit_context_new_binary_op (comp.ctxt, - NULL, - GCC_JIT_BINARY_OP_BITWISE_AND, - comp.unsigned_type, - minus_res, - gcc_jit_context_new_rvalue_from_int ( - comp.ctxt, - comp.unsigned_type, - ((1 << INTTYPEBITS) - 1)))); + emit_binary_op ( + GCC_JIT_BINARY_OP_BITWISE_AND, + comp.unsigned_type, + minus_res, + gcc_jit_context_new_rvalue_from_int ( + comp.ctxt, + comp.unsigned_type, + ((1 << INTTYPEBITS) - 1)))); return res; } @@ -989,27 +980,21 @@ emit_XFIXNUM (gcc_jit_rvalue *obj) if (!USE_LSB_TAG) { - i = gcc_jit_context_new_binary_op (comp.ctxt, - NULL, - GCC_JIT_BINARY_OP_LSHIFT, - comp.emacs_uint_type, - emit_coerce (comp.emacs_uint_type, i), - comp.inttypebits); + i = emit_binary_op (GCC_JIT_BINARY_OP_LSHIFT, + comp.emacs_uint_type, + i, + comp.inttypebits); - return gcc_jit_context_new_binary_op (comp.ctxt, - NULL, - GCC_JIT_BINARY_OP_RSHIFT, - comp.emacs_int_type, - i, - comp.inttypebits); + return emit_binary_op (GCC_JIT_BINARY_OP_RSHIFT, + comp.emacs_int_type, + i, + comp.inttypebits); } else - return gcc_jit_context_new_binary_op (comp.ctxt, - NULL, - GCC_JIT_BINARY_OP_LSHIFT, - comp.emacs_int_type, - i, - comp.inttypebits); + return emit_binary_op (GCC_JIT_BINARY_OP_LSHIFT, + comp.emacs_int_type, + i, + comp.inttypebits); } static gcc_jit_rvalue * @@ -1017,13 +1002,10 @@ emit_INTEGERP (gcc_jit_rvalue *obj) { emit_comment ("INTEGERP"); - return gcc_jit_context_new_binary_op (comp.ctxt, - NULL, - GCC_JIT_BINARY_OP_LOGICAL_OR, - comp.bool_type, - emit_coerce (comp.bool_type, - emit_FIXNUMP (obj)), - emit_BIGNUMP (obj)); + return emit_binary_op (GCC_JIT_BINARY_OP_LOGICAL_OR, + comp.bool_type, + emit_FIXNUMP (obj), + emit_BIGNUMP (obj)); } static gcc_jit_rvalue * @@ -1031,13 +1013,10 @@ emit_NUMBERP (gcc_jit_rvalue *obj) { emit_comment ("NUMBERP"); - return gcc_jit_context_new_binary_op (comp.ctxt, - NULL, - GCC_JIT_BINARY_OP_LOGICAL_OR, - comp.bool_type, - emit_INTEGERP (obj), - emit_coerce (comp.bool_type, - emit_FLOATP (obj))); + return emit_binary_op (GCC_JIT_BINARY_OP_LOGICAL_OR, + comp.bool_type, + emit_INTEGERP (obj), + emit_FLOATP (obj)); } static gcc_jit_rvalue * @@ -1050,19 +1029,13 @@ emit_make_fixnum_LSB_TAG (gcc_jit_rvalue *n) */ gcc_jit_rvalue *tmp = - gcc_jit_context_new_binary_op (comp.ctxt, - NULL, - GCC_JIT_BINARY_OP_LSHIFT, - comp.emacs_int_type, - emit_coerce (comp.emacs_uint_type, n), - comp.inttypebits); + emit_binary_op (GCC_JIT_BINARY_OP_LSHIFT, + comp.emacs_int_type, + n, comp.inttypebits); - tmp = gcc_jit_context_new_binary_op (comp.ctxt, - NULL, - GCC_JIT_BINARY_OP_PLUS, - comp.emacs_int_type, - tmp, - comp.lisp_int0); + tmp = emit_binary_op (GCC_JIT_BINARY_OP_PLUS, + comp.emacs_int_type, + tmp, comp.lisp_int0); gcc_jit_lvalue *res = gcc_jit_function_new_local (comp.func, NULL, @@ -1090,29 +1063,21 @@ emit_make_fixnum_MSB_TAG (gcc_jit_rvalue *n) emit_coerce (comp.emacs_uint_type, emit_rvalue_from_long_long ((EMACS_INT_MAX >> (INTTYPEBITS - 1)))); - n = gcc_jit_context_new_binary_op ( - comp.ctxt, - NULL, - GCC_JIT_BINARY_OP_BITWISE_AND, - comp.emacs_uint_type, - intmask, - emit_coerce (comp.emacs_uint_type, n)); + n = emit_binary_op (GCC_JIT_BINARY_OP_BITWISE_AND, + comp.emacs_uint_type, + intmask, n); - n = gcc_jit_context_new_binary_op ( - comp.ctxt, - NULL, - GCC_JIT_BINARY_OP_PLUS, - comp.emacs_uint_type, - gcc_jit_context_new_binary_op ( - comp.ctxt, - NULL, - GCC_JIT_BINARY_OP_LSHIFT, - comp.emacs_uint_type, - emit_coerce (comp.emacs_uint_type, comp.lisp_int0), - gcc_jit_context_new_rvalue_from_int (comp.ctxt, - comp.emacs_uint_type, - VALBITS)), - n); + n = + emit_binary_op (GCC_JIT_BINARY_OP_PLUS, + comp.emacs_uint_type, + emit_binary_op (GCC_JIT_BINARY_OP_LSHIFT, + comp.emacs_uint_type, + comp.lisp_int0, + gcc_jit_context_new_rvalue_from_int ( + comp.ctxt, + comp.emacs_uint_type, + VALBITS)), + n); return emit_XLI (emit_coerce (comp.emacs_int_type, n)); } @@ -1321,15 +1286,12 @@ emit_PURE_P (gcc_jit_rvalue *ptr) comp.ctxt, NULL, GCC_JIT_COMPARISON_LE, - gcc_jit_context_new_binary_op ( - comp.ctxt, - NULL, + emit_binary_op ( GCC_JIT_BINARY_OP_MINUS, comp.uintptr_type, - emit_coerce (comp.uintptr_type, ptr), - emit_coerce (comp.uintptr_type, - gcc_jit_lvalue_as_rvalue ( - gcc_jit_rvalue_dereference (comp.pure_ref, NULL)))), + ptr, + gcc_jit_lvalue_as_rvalue ( + gcc_jit_rvalue_dereference (comp.pure_ref, NULL))), gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.uintptr_type, PURESIZE)); @@ -1611,7 +1573,7 @@ emit_limple_insn (Lisp_Object insn) */ gcc_jit_lvalue *m_handlerlist = gcc_jit_rvalue_dereference_field ( - gcc_jit_lvalue_as_rvalue ( + gcc_jit_lvalue_as_rvalue ( gcc_jit_rvalue_dereference (comp.current_thread_ref, NULL)), NULL, comp.m_handlerlist); @@ -1630,7 +1592,7 @@ emit_limple_insn (Lisp_Object insn) else if (EQ (op, Qfetch_handler)) { gcc_jit_lvalue *m_handlerlist = - gcc_jit_rvalue_dereference_field ( + gcc_jit_rvalue_dereference_field ( gcc_jit_lvalue_as_rvalue ( gcc_jit_rvalue_dereference (comp.current_thread_ref, NULL)), NULL, @@ -1641,18 +1603,18 @@ emit_limple_insn (Lisp_Object insn) gcc_jit_lvalue_as_rvalue (m_handlerlist)); gcc_jit_block_add_assignment ( - comp.block, - NULL, - m_handlerlist, - gcc_jit_lvalue_as_rvalue ( - gcc_jit_rvalue_dereference_field ( + comp.block, + NULL, + m_handlerlist, + gcc_jit_lvalue_as_rvalue ( + gcc_jit_rvalue_dereference_field ( gcc_jit_lvalue_as_rvalue (comp.loc_handler), NULL, comp.handler_next_field))); emit_frame_assignment ( - arg[0], - gcc_jit_lvalue_as_rvalue ( - gcc_jit_rvalue_dereference_field ( + arg[0], + gcc_jit_lvalue_as_rvalue ( + gcc_jit_rvalue_dereference_field ( gcc_jit_lvalue_as_rvalue (comp.loc_handler), NULL, comp.handler_val_field))); @@ -1745,12 +1707,10 @@ emit_limple_insn (Lisp_Object insn) gcc_jit_param_as_lvalue (gcc_jit_function_get_param (comp.func, 1)); gcc_jit_rvalue *list_args[] = - { gcc_jit_context_new_binary_op (comp.ctxt, - NULL, - GCC_JIT_BINARY_OP_MINUS, - comp.ptrdiff_type, - gcc_jit_lvalue_as_rvalue (nargs), - n), + { emit_binary_op (GCC_JIT_BINARY_OP_MINUS, + comp.ptrdiff_type, + gcc_jit_lvalue_as_rvalue (nargs), + n), gcc_jit_lvalue_as_rvalue (args) }; res = emit_call (Qlist, comp.lisp_obj_type, 2, @@ -2124,31 +2084,31 @@ emit_ctxt_code (void) comp.current_thread_ref = gcc_jit_lvalue_as_rvalue ( gcc_jit_context_new_global ( - comp.ctxt, - NULL, - GCC_JIT_GLOBAL_EXPORTED, - gcc_jit_type_get_pointer (comp.thread_state_ptr_type), - CURRENT_THREAD_RELOC_SYM)); + comp.ctxt, + NULL, + GCC_JIT_GLOBAL_EXPORTED, + gcc_jit_type_get_pointer (comp.thread_state_ptr_type), + CURRENT_THREAD_RELOC_SYM)); comp.pure_ref = gcc_jit_lvalue_as_rvalue ( gcc_jit_context_new_global ( - comp.ctxt, - NULL, - GCC_JIT_GLOBAL_EXPORTED, - gcc_jit_type_get_pointer (comp.void_ptr_type), - PURE_RELOC_SYM)); + comp.ctxt, + NULL, + GCC_JIT_GLOBAL_EXPORTED, + gcc_jit_type_get_pointer (comp.void_ptr_type), + PURE_RELOC_SYM)); gcc_jit_context_new_global ( - comp.ctxt, - NULL, - GCC_JIT_GLOBAL_EXPORTED, - gcc_jit_type_get_pointer (comp.lisp_obj_ptr_type), - COMP_UNIT_SYM); + comp.ctxt, + NULL, + GCC_JIT_GLOBAL_EXPORTED, + gcc_jit_type_get_pointer (comp.lisp_obj_ptr_type), + COMP_UNIT_SYM); declare_imported_data (); - /* Functions imported from Lisp code. */ + /* Functions imported from Lisp code. */ freloc_check_fill (); gcc_jit_field **fields = xmalloc (freloc.size * sizeof (*fields)); ptrdiff_t n_frelocs = 0; @@ -2621,16 +2581,12 @@ define_CAR_CDR (void) DECL_BLOCK (not_a_cons_b, func[i]); comp.block = entry_block; comp.func = func[i]; - emit_cond_jump ( - gcc_jit_context_new_binary_op (comp.ctxt, - NULL, - GCC_JIT_BINARY_OP_LOGICAL_OR, - comp.bool_type, - gcc_jit_param_as_rvalue (param[1]), - emit_coerce (comp.bool_type, - emit_CONSP (c))), - is_cons_b, - not_a_cons_b); + emit_cond_jump (emit_binary_op (GCC_JIT_BINARY_OP_LOGICAL_OR, + comp.bool_type, + gcc_jit_param_as_rvalue (param[1]), + emit_CONSP (c)), + is_cons_b, + not_a_cons_b); comp.block = is_cons_b; if (i == 0) gcc_jit_block_end_with_return (comp.block, NULL, emit_XCAR (c)); @@ -2780,19 +2736,12 @@ define_add1_sub1 (void) gcc_jit_rvalue *n = gcc_jit_param_as_rvalue (param[0]); gcc_jit_rvalue *n_fixnum = emit_XFIXNUM (n); gcc_jit_rvalue *sure_fixnum = - gcc_jit_context_new_binary_op ( - comp.ctxt, - NULL, - GCC_JIT_BINARY_OP_LOGICAL_OR, - comp.bool_type, - gcc_jit_param_as_rvalue (param[1]), - emit_coerce (comp.bool_type, - emit_FIXNUMP (n))); - + emit_binary_op (GCC_JIT_BINARY_OP_LOGICAL_OR, + comp.bool_type, + gcc_jit_param_as_rvalue (param[1]), + emit_FIXNUMP (n)); emit_cond_jump ( - gcc_jit_context_new_binary_op ( - comp.ctxt, - NULL, + emit_binary_op ( GCC_JIT_BINARY_OP_LOGICAL_AND, comp.bool_type, sure_fixnum, @@ -2808,12 +2757,7 @@ define_add1_sub1 (void) comp.block = inline_block; gcc_jit_rvalue *inline_res = - gcc_jit_context_new_binary_op (comp.ctxt, - NULL, - op[i], - comp.emacs_int_type, - n_fixnum, - comp.one); + emit_binary_op (op[i], comp.emacs_int_type, n_fixnum, comp.one); gcc_jit_block_end_with_return (inline_block, NULL, @@ -2864,29 +2808,22 @@ define_negate (void) gcc_jit_lvalue *n = gcc_jit_param_as_lvalue (param[0]); gcc_jit_rvalue *n_fixnum = emit_XFIXNUM (gcc_jit_lvalue_as_rvalue (n)); gcc_jit_rvalue *sure_fixnum = - gcc_jit_context_new_binary_op ( - comp.ctxt, - NULL, - GCC_JIT_BINARY_OP_LOGICAL_OR, - comp.bool_type, - gcc_jit_param_as_rvalue (param[1]), - emit_coerce (comp.bool_type, - emit_FIXNUMP (gcc_jit_lvalue_as_rvalue (n)))); + emit_binary_op (GCC_JIT_BINARY_OP_LOGICAL_OR, + comp.bool_type, + gcc_jit_param_as_rvalue (param[1]), + emit_FIXNUMP (gcc_jit_lvalue_as_rvalue (n))); - emit_cond_jump ( - gcc_jit_context_new_binary_op ( - comp.ctxt, - NULL, - GCC_JIT_BINARY_OP_LOGICAL_AND, - comp.bool_type, - sure_fixnum, - gcc_jit_context_new_comparison (comp.ctxt, - NULL, - GCC_JIT_COMPARISON_NE, - n_fixnum, - emit_most_negative_fixnum ())), - inline_block, - fcall_block); + emit_cond_jump (emit_binary_op (GCC_JIT_BINARY_OP_LOGICAL_AND, + comp.bool_type, + sure_fixnum, + gcc_jit_context_new_comparison ( + comp.ctxt, + NULL, + GCC_JIT_COMPARISON_NE, + n_fixnum, + emit_most_negative_fixnum ())), + inline_block, + fcall_block); comp.block = inline_block; gcc_jit_rvalue *inline_res = commit e3dff709b75c83c3939727538aa0bd072c268687 Author: Andrea Corallo Date: Sun Apr 5 14:24:00 2020 +0100 * src/comp.c: Emit cast only when necessary. Coerce only when the destination type is different from the current one. diff --git a/src/comp.c b/src/comp.c index 605e92680c..75a2534b2e 100644 --- a/src/comp.c +++ b/src/comp.c @@ -605,12 +605,17 @@ emit_cond_jump (gcc_jit_rvalue *test, } static gcc_jit_rvalue * -emit_cast (gcc_jit_type *new_type, gcc_jit_rvalue *obj) +emit_coerce (gcc_jit_type *new_type, gcc_jit_rvalue *obj) { static ptrdiff_t i; + gcc_jit_type *old_type = gcc_jit_rvalue_get_type (obj); + + if (new_type == old_type) + return obj; + gcc_jit_field *orig_field = - type_to_cast_field (gcc_jit_rvalue_get_type (obj)); + type_to_cast_field (old_type); gcc_jit_field *dest_field = type_to_cast_field (new_type); gcc_jit_lvalue *tmp_u = @@ -667,7 +672,7 @@ emit_rvalue_from_long_long (long long n) 32)); return - emit_cast (comp.long_long_type, + emit_coerce (comp.long_long_type, gcc_jit_context_new_binary_op ( comp.ctxt, NULL, @@ -729,17 +734,17 @@ emit_ptr_arithmetic (gcc_jit_rvalue *ptr, gcc_jit_type *ptr_type, gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.uintptr_type, size_of_ptr_ref), - emit_cast (comp.uintptr_type, i)); + emit_coerce (comp.uintptr_type, i)); return - emit_cast ( + emit_coerce ( ptr_type, gcc_jit_context_new_binary_op ( comp.ctxt, NULL, GCC_JIT_BINARY_OP_PLUS, comp.uintptr_type, - emit_cast (comp.uintptr_type, ptr), + emit_coerce (comp.uintptr_type, ptr), offset)); } @@ -785,7 +790,7 @@ emit_XUNTAG (gcc_jit_rvalue *a, gcc_jit_type *type, long long lisp_word_tag) emit_comment ("XUNTAG"); #ifndef WIDE_EMACS_INT - return emit_cast ( + return emit_coerce ( gcc_jit_type_get_pointer (type), gcc_jit_context_new_binary_op ( comp.ctxt, @@ -798,7 +803,7 @@ emit_XUNTAG (gcc_jit_rvalue *a, gcc_jit_type *type, long long lisp_word_tag) comp.emacs_int_type, lisp_word_tag))); #else - return emit_cast ( + return emit_coerce ( gcc_jit_type_get_pointer (type), gcc_jit_context_new_binary_op ( comp.ctxt, @@ -806,9 +811,9 @@ emit_XUNTAG (gcc_jit_rvalue *a, gcc_jit_type *type, long long lisp_word_tag) GCC_JIT_BINARY_OP_MINUS, comp.unsigned_long_long_type, /* FIXME Should be XLP. */ - emit_cast (comp.unsigned_long_long_type, emit_XLI (a)), - emit_cast (comp.unsigned_long_long_type, - emit_rvalue_from_long_long (lisp_word_tag)))); + emit_coerce (comp.unsigned_long_long_type, emit_XLI (a)), + emit_coerce (comp.unsigned_long_long_type, + emit_rvalue_from_long_long (lisp_word_tag)))); #endif } @@ -859,7 +864,7 @@ emit_TAGGEDP (gcc_jit_rvalue *obj, ptrdiff_t tag) NULL, GCC_JIT_BINARY_OP_MINUS, comp.unsigned_type, - emit_cast (comp.unsigned_type, sh_res), + emit_coerce (comp.unsigned_type, sh_res), gcc_jit_context_new_rvalue_from_int ( comp.ctxt, comp.unsigned_type, @@ -951,7 +956,7 @@ emit_FIXNUMP (gcc_jit_rvalue *obj) NULL, GCC_JIT_BINARY_OP_MINUS, comp.unsigned_type, - emit_cast (comp.unsigned_type, sh_res), + emit_coerce (comp.unsigned_type, sh_res), gcc_jit_context_new_rvalue_from_int ( comp.ctxt, comp.unsigned_type, @@ -980,7 +985,7 @@ static gcc_jit_rvalue * emit_XFIXNUM (gcc_jit_rvalue *obj) { emit_comment ("XFIXNUM"); - gcc_jit_rvalue *i = emit_cast (comp.emacs_uint_type, emit_XLI (obj)); + gcc_jit_rvalue *i = emit_coerce (comp.emacs_uint_type, emit_XLI (obj)); if (!USE_LSB_TAG) { @@ -988,7 +993,7 @@ emit_XFIXNUM (gcc_jit_rvalue *obj) NULL, GCC_JIT_BINARY_OP_LSHIFT, comp.emacs_uint_type, - emit_cast (comp.emacs_uint_type, i), + emit_coerce (comp.emacs_uint_type, i), comp.inttypebits); return gcc_jit_context_new_binary_op (comp.ctxt, @@ -1016,8 +1021,8 @@ emit_INTEGERP (gcc_jit_rvalue *obj) NULL, GCC_JIT_BINARY_OP_LOGICAL_OR, comp.bool_type, - emit_cast (comp.bool_type, - emit_FIXNUMP (obj)), + emit_coerce (comp.bool_type, + emit_FIXNUMP (obj)), emit_BIGNUMP (obj)); } @@ -1031,8 +1036,8 @@ emit_NUMBERP (gcc_jit_rvalue *obj) GCC_JIT_BINARY_OP_LOGICAL_OR, comp.bool_type, emit_INTEGERP (obj), - emit_cast (comp.bool_type, - emit_FLOATP (obj))); + emit_coerce (comp.bool_type, + emit_FLOATP (obj))); } static gcc_jit_rvalue * @@ -1049,7 +1054,7 @@ emit_make_fixnum_LSB_TAG (gcc_jit_rvalue *n) NULL, GCC_JIT_BINARY_OP_LSHIFT, comp.emacs_int_type, - emit_cast (comp.emacs_uint_type, n), + emit_coerce (comp.emacs_uint_type, n), comp.inttypebits); tmp = gcc_jit_context_new_binary_op (comp.ctxt, @@ -1082,16 +1087,16 @@ emit_make_fixnum_MSB_TAG (gcc_jit_rvalue *n) */ gcc_jit_rvalue *intmask = - emit_cast (comp.emacs_uint_type, - emit_rvalue_from_long_long ((EMACS_INT_MAX - >> (INTTYPEBITS - 1)))); + emit_coerce (comp.emacs_uint_type, + emit_rvalue_from_long_long ((EMACS_INT_MAX + >> (INTTYPEBITS - 1)))); n = gcc_jit_context_new_binary_op ( comp.ctxt, NULL, GCC_JIT_BINARY_OP_BITWISE_AND, comp.emacs_uint_type, intmask, - emit_cast (comp.emacs_uint_type, n)); + emit_coerce (comp.emacs_uint_type, n)); n = gcc_jit_context_new_binary_op ( comp.ctxt, @@ -1103,12 +1108,12 @@ emit_make_fixnum_MSB_TAG (gcc_jit_rvalue *n) NULL, GCC_JIT_BINARY_OP_LSHIFT, comp.emacs_uint_type, - emit_cast (comp.emacs_uint_type, comp.lisp_int0), + emit_coerce (comp.emacs_uint_type, comp.lisp_int0), gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.emacs_uint_type, VALBITS)), n); - return emit_XLI (emit_cast (comp.emacs_int_type, n)); + return emit_XLI (emit_coerce (comp.emacs_int_type, n)); } @@ -1128,10 +1133,10 @@ emit_const_lisp_obj (Lisp_Object obj) SSDATA (Fprin1_to_string (obj, Qnil)))); if (NIL_IS_ZERO && EQ (obj, Qnil)) - return emit_cast (comp.lisp_obj_type, - gcc_jit_context_new_rvalue_from_ptr (comp.ctxt, - comp.void_ptr_type, - NULL)); + return emit_coerce (comp.lisp_obj_type, + gcc_jit_context_new_rvalue_from_ptr (comp.ctxt, + comp.void_ptr_type, + NULL)); imm_reloc_t reloc = obj_to_reloc (obj); return gcc_jit_lvalue_as_rvalue ( @@ -1321,10 +1326,10 @@ emit_PURE_P (gcc_jit_rvalue *ptr) NULL, GCC_JIT_BINARY_OP_MINUS, comp.uintptr_type, - emit_cast (comp.uintptr_type, ptr), - emit_cast (comp.uintptr_type, - gcc_jit_lvalue_as_rvalue ( - gcc_jit_rvalue_dereference (comp.pure_ref, NULL)))), + emit_coerce (comp.uintptr_type, ptr), + emit_coerce (comp.uintptr_type, + gcc_jit_lvalue_as_rvalue ( + gcc_jit_rvalue_dereference (comp.pure_ref, NULL)))), gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.uintptr_type, PURESIZE)); @@ -1358,7 +1363,7 @@ emit_mvar_val (Lisp_Object mvar) : gcc_jit_context_new_rvalue_from_long (comp.ctxt, comp.void_ptr_type, constant); - return emit_cast (comp.lisp_obj_type, word); + return emit_coerce (comp.lisp_obj_type, word); } /* Other const objects are fetched from the reloc array. */ return emit_const_lisp_obj (constant); @@ -1861,7 +1866,7 @@ static gcc_jit_rvalue * emit_consp (Lisp_Object insn) { gcc_jit_rvalue *x = emit_mvar_val (SECOND (insn)); - gcc_jit_rvalue *res = emit_cast (comp.bool_type, + gcc_jit_rvalue *res = emit_coerce (comp.bool_type, emit_CONSP (x)); return gcc_jit_context_new_call (comp.ctxt, NULL, @@ -2622,8 +2627,8 @@ define_CAR_CDR (void) GCC_JIT_BINARY_OP_LOGICAL_OR, comp.bool_type, gcc_jit_param_as_rvalue (param[1]), - emit_cast (comp.bool_type, - emit_CONSP (c))), + emit_coerce (comp.bool_type, + emit_CONSP (c))), is_cons_b, not_a_cons_b); comp.block = is_cons_b; @@ -2781,8 +2786,8 @@ define_add1_sub1 (void) GCC_JIT_BINARY_OP_LOGICAL_OR, comp.bool_type, gcc_jit_param_as_rvalue (param[1]), - emit_cast (comp.bool_type, - emit_FIXNUMP (n))); + emit_coerce (comp.bool_type, + emit_FIXNUMP (n))); emit_cond_jump ( gcc_jit_context_new_binary_op ( @@ -2865,8 +2870,8 @@ define_negate (void) GCC_JIT_BINARY_OP_LOGICAL_OR, comp.bool_type, gcc_jit_param_as_rvalue (param[1]), - emit_cast (comp.bool_type, - emit_FIXNUMP (gcc_jit_lvalue_as_rvalue (n)))); + emit_coerce (comp.bool_type, + emit_FIXNUMP (gcc_jit_lvalue_as_rvalue (n)))); emit_cond_jump ( gcc_jit_context_new_binary_op ( commit 49a3790e684213a6247f20e8029947f82fefdb5b Author: Andrea Corallo Date: Sat Apr 4 23:33:52 2020 +0100 * src/comp.c: Add MSB TAG and wide int support. diff --git a/src/comp.c b/src/comp.c index f89414a310..605e92680c 100644 --- a/src/comp.c +++ b/src/comp.c @@ -101,6 +101,7 @@ typedef struct { gcc_jit_type *long_long_type; gcc_jit_type *unsigned_long_long_type; gcc_jit_type *emacs_int_type; + gcc_jit_type *emacs_uint_type; gcc_jit_type *void_ptr_type; gcc_jit_type *char_ptr_type; gcc_jit_type *ptrdiff_type; @@ -155,8 +156,6 @@ typedef struct { gcc_jit_block *block; /* Current basic block being compiled. */ gcc_jit_lvalue *scratch; /* Used as scratch slot for some code sequence (switch). */ gcc_jit_lvalue ***arrays; /* Array index -> gcc_jit_lvalue **. */ - gcc_jit_rvalue *most_positive_fixnum; - gcc_jit_rvalue *most_negative_fixnum; gcc_jit_rvalue *one; gcc_jit_rvalue *inttypebits; gcc_jit_rvalue *lisp_int0; @@ -631,6 +630,85 @@ emit_cast (gcc_jit_type *new_type, gcc_jit_rvalue *obj) dest_field); } + +/* Should come with libgccjit. */ + +static gcc_jit_rvalue * +emit_rvalue_from_long_long (long long n) +{ +#ifndef WIDE_EMACS_INT + xsignal1 (Qnative_ice, + build_string ("emit_rvalue_from_long_long called in non wide int" + " configuration")); +#endif + + emit_comment (format_string ("emit long long: %lld", n)); + + gcc_jit_rvalue *high = + gcc_jit_context_new_rvalue_from_long (comp.ctxt, + comp.unsigned_long_long_type, + (unsigned long long)n >> 32); + gcc_jit_rvalue *low = + emit_binary_op (GCC_JIT_BINARY_OP_RSHIFT, + comp.unsigned_long_long_type, + emit_binary_op (GCC_JIT_BINARY_OP_LSHIFT, + comp.unsigned_long_long_type, + gcc_jit_context_new_rvalue_from_long ( + comp.ctxt, + comp.unsigned_long_long_type, + n), + gcc_jit_context_new_rvalue_from_int ( + comp.ctxt, + comp.unsigned_long_long_type, + 32)), + gcc_jit_context_new_rvalue_from_int ( + comp.ctxt, + comp.unsigned_long_long_type, + 32)); + + return + emit_cast (comp.long_long_type, + gcc_jit_context_new_binary_op ( + comp.ctxt, + NULL, + GCC_JIT_BINARY_OP_BITWISE_OR, + comp.unsigned_long_long_type, + gcc_jit_context_new_binary_op ( + comp.ctxt, + NULL, + GCC_JIT_BINARY_OP_LSHIFT, + comp.unsigned_long_long_type, + high, + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.unsigned_long_long_type, + 32)), + low)); +} + +static gcc_jit_rvalue * +emit_most_positive_fixnum (void) +{ +#if EMACS_INT_MAX > LONG_MAX + return emit_rvalue_from_long_long (MOST_POSITIVE_FIXNUM); +#else + return gcc_jit_context_new_rvalue_from_long (comp.ctxt, + comp.emacs_int_type, + MOST_POSITIVE_FIXNUM); +#endif +} + +static gcc_jit_rvalue * +emit_most_negative_fixnum (void) +{ +#if EMACS_INT_MAX > LONG_MAX + return emit_rvalue_from_long_long (MOST_NEGATIVE_FIXNUM); +#else + return gcc_jit_context_new_rvalue_from_long (comp.ctxt, + comp.emacs_int_type, + MOST_NEGATIVE_FIXNUM); +#endif +} + /* Emit the equivalent of: (typeof_ptr) ((uintptr) ptr + size_of_ptr_ref * i) @@ -700,22 +778,38 @@ emit_lval_XLP (gcc_jit_lvalue *obj) comp.lisp_obj_as_ptr); } */ static gcc_jit_rvalue * -emit_XUNTAG (gcc_jit_rvalue *a, gcc_jit_type *type, ptrdiff_t lisp_word_tag) +emit_XUNTAG (gcc_jit_rvalue *a, gcc_jit_type *type, long long lisp_word_tag) { /* #define XUNTAG(a, type, ctype) ((ctype *) ((char *) XLP (a) - LISP_WORD_TAG (type))) */ emit_comment ("XUNTAG"); - return emit_cast (gcc_jit_type_get_pointer (type), +#ifndef WIDE_EMACS_INT + return emit_cast ( + gcc_jit_type_get_pointer (type), gcc_jit_context_new_binary_op ( comp.ctxt, NULL, GCC_JIT_BINARY_OP_MINUS, comp.emacs_int_type, emit_XLI (a), - gcc_jit_context_new_rvalue_from_int (comp.ctxt, - comp.emacs_int_type, - lisp_word_tag))); + gcc_jit_context_new_rvalue_from_int ( + comp.ctxt, + comp.emacs_int_type, + lisp_word_tag))); +#else + return emit_cast ( + gcc_jit_type_get_pointer (type), + gcc_jit_context_new_binary_op ( + comp.ctxt, + NULL, + GCC_JIT_BINARY_OP_MINUS, + comp.unsigned_long_long_type, + /* FIXME Should be XLP. */ + emit_cast (comp.unsigned_long_long_type, emit_XLI (a)), + emit_cast (comp.unsigned_long_long_type, + emit_rvalue_from_long_long (lisp_word_tag)))); +#endif } static gcc_jit_rvalue * @@ -886,13 +980,31 @@ static gcc_jit_rvalue * emit_XFIXNUM (gcc_jit_rvalue *obj) { emit_comment ("XFIXNUM"); + gcc_jit_rvalue *i = emit_cast (comp.emacs_uint_type, emit_XLI (obj)); - return gcc_jit_context_new_binary_op (comp.ctxt, - NULL, - GCC_JIT_BINARY_OP_RSHIFT, - comp.emacs_int_type, - emit_XLI (obj), - comp.inttypebits); + if (!USE_LSB_TAG) + { + i = gcc_jit_context_new_binary_op (comp.ctxt, + NULL, + GCC_JIT_BINARY_OP_LSHIFT, + comp.emacs_uint_type, + emit_cast (comp.emacs_uint_type, i), + comp.inttypebits); + + return gcc_jit_context_new_binary_op (comp.ctxt, + NULL, + GCC_JIT_BINARY_OP_RSHIFT, + comp.emacs_int_type, + i, + comp.inttypebits); + } + else + return gcc_jit_context_new_binary_op (comp.ctxt, + NULL, + GCC_JIT_BINARY_OP_LSHIFT, + comp.emacs_int_type, + i, + comp.inttypebits); } static gcc_jit_rvalue * @@ -924,16 +1036,20 @@ emit_NUMBERP (gcc_jit_rvalue *obj) } static gcc_jit_rvalue * -emit_make_fixnum (gcc_jit_rvalue *obj) +emit_make_fixnum_LSB_TAG (gcc_jit_rvalue *n) { - emit_comment ("make_fixnum"); + /* + EMACS_UINT u = n; + n = u << INTTYPEBITS; + n += int0; + */ gcc_jit_rvalue *tmp = gcc_jit_context_new_binary_op (comp.ctxt, NULL, GCC_JIT_BINARY_OP_LSHIFT, comp.emacs_int_type, - obj, + emit_cast (comp.emacs_uint_type, n), comp.inttypebits); tmp = gcc_jit_context_new_binary_op (comp.ctxt, @@ -956,6 +1072,55 @@ emit_make_fixnum (gcc_jit_rvalue *obj) return gcc_jit_lvalue_as_rvalue (res); } +static gcc_jit_rvalue * +emit_make_fixnum_MSB_TAG (gcc_jit_rvalue *n) +{ + /* + n &= INTMASK; + n += (int0 << VALBITS); + return XIL (n); + */ + + gcc_jit_rvalue *intmask = + emit_cast (comp.emacs_uint_type, + emit_rvalue_from_long_long ((EMACS_INT_MAX + >> (INTTYPEBITS - 1)))); + n = gcc_jit_context_new_binary_op ( + comp.ctxt, + NULL, + GCC_JIT_BINARY_OP_BITWISE_AND, + comp.emacs_uint_type, + intmask, + emit_cast (comp.emacs_uint_type, n)); + + n = gcc_jit_context_new_binary_op ( + comp.ctxt, + NULL, + GCC_JIT_BINARY_OP_PLUS, + comp.emacs_uint_type, + gcc_jit_context_new_binary_op ( + comp.ctxt, + NULL, + GCC_JIT_BINARY_OP_LSHIFT, + comp.emacs_uint_type, + emit_cast (comp.emacs_uint_type, comp.lisp_int0), + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.emacs_uint_type, + VALBITS)), + n); + return emit_XLI (emit_cast (comp.emacs_int_type, n)); +} + + +static gcc_jit_rvalue * +emit_make_fixnum (gcc_jit_rvalue *obj) +{ + emit_comment ("make_fixnum"); + return USE_LSB_TAG + ? emit_make_fixnum_LSB_TAG (obj) + : emit_make_fixnum_MSB_TAG (obj); +} + static gcc_jit_rvalue * emit_const_lisp_obj (Lisp_Object obj) { @@ -1188,9 +1353,11 @@ emit_mvar_val (Lisp_Object mvar) word (read fixnums). */ emit_comment (SSDATA (Fprin1_to_string (constant, Qnil))); gcc_jit_rvalue *word = - gcc_jit_context_new_rvalue_from_ptr (comp.ctxt, - comp.void_ptr_type, - constant); + (sizeof (MOST_POSITIVE_FIXNUM) > sizeof (void *)) + ? emit_rvalue_from_long_long (constant) + : gcc_jit_context_new_rvalue_from_long (comp.ctxt, + comp.void_ptr_type, + constant); return emit_cast (comp.lisp_obj_type, word); } /* Other const objects are fetched from the reloc array. */ @@ -2574,8 +2741,6 @@ define_add1_sub1 (void) gcc_jit_function *func[2]; char const *f_name[] = { "add1", "sub1" }; char const *fall_back_func[] = { "1+", "1-" }; - gcc_jit_rvalue *compare[] = - { comp.most_positive_fixnum, comp.most_negative_fixnum }; enum gcc_jit_binary_op op[] = { GCC_JIT_BINARY_OP_PLUS, GCC_JIT_BINARY_OP_MINUS }; for (ptrdiff_t i = 0; i < 2; i++) @@ -2630,7 +2795,9 @@ define_add1_sub1 (void) NULL, GCC_JIT_COMPARISON_NE, n_fixnum, - compare[i])), + i == 0 + ? emit_most_positive_fixnum () + : emit_most_negative_fixnum ())), inline_block, fcall_block); @@ -2712,7 +2879,7 @@ define_negate (void) NULL, GCC_JIT_COMPARISON_NE, n_fixnum, - comp.most_negative_fixnum)), + emit_most_negative_fixnum ())), inline_block, fcall_block); @@ -3127,25 +3294,20 @@ DEFUN ("comp--init-ctxt", Fcomp__init_ctxt, Scomp__init_ctxt, comp.emacs_int_type = gcc_jit_context_get_int_type (comp.ctxt, sizeof (EMACS_INT), true); + comp.emacs_uint_type = gcc_jit_context_get_int_type (comp.ctxt, + sizeof (EMACS_UINT), + false); /* No XLP is emitted for now so lets define this always as integer disregarding LISP_WORDS_ARE_POINTERS value. */ comp.lisp_obj_type = comp.emacs_int_type; comp.lisp_obj_ptr_type = gcc_jit_type_get_pointer (comp.lisp_obj_type); - comp.most_positive_fixnum = - gcc_jit_context_new_rvalue_from_long (comp.ctxt, - comp.emacs_int_type, - MOST_POSITIVE_FIXNUM); - comp.most_negative_fixnum = - gcc_jit_context_new_rvalue_from_long (comp.ctxt, - comp.emacs_int_type, - MOST_NEGATIVE_FIXNUM); comp.one = gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.emacs_int_type, 1); comp.inttypebits = gcc_jit_context_new_rvalue_from_int (comp.ctxt, - comp.emacs_int_type, + comp.emacs_uint_type, INTTYPEBITS); comp.lisp_int0 = gcc_jit_context_new_rvalue_from_int (comp.ctxt, commit 70cb9644817ef59446d0705ba1362f200b3bd13d Author: Andrea Corallo Date: Fri Apr 3 21:19:45 2020 +0100 * src/comp.c: Clean-up unnecessary field declaration. diff --git a/src/comp.c b/src/comp.c index 935b7aafda..f89414a310 100644 --- a/src/comp.c +++ b/src/comp.c @@ -107,7 +107,6 @@ typedef struct { gcc_jit_type *uintptr_type; gcc_jit_type *lisp_obj_type; gcc_jit_type *lisp_obj_ptr_type; - gcc_jit_field *lisp_obj_as_num; /* struct Lisp_Cons */ gcc_jit_struct *lisp_cons_s; gcc_jit_field *lisp_cons_u; @@ -3128,10 +3127,6 @@ DEFUN ("comp--init-ctxt", Fcomp__init_ctxt, Scomp__init_ctxt, comp.emacs_int_type = gcc_jit_context_get_int_type (comp.ctxt, sizeof (EMACS_INT), true); - comp.lisp_obj_as_num = gcc_jit_context_new_field (comp.ctxt, - NULL, - comp.emacs_int_type, - "num"); /* No XLP is emitted for now so lets define this always as integer disregarding LISP_WORDS_ARE_POINTERS value. */ comp.lisp_obj_type = comp.emacs_int_type; commit 37a9d1e42b568b6a7b528ef40a209ab6658ff358 Author: Andrea Corallo Date: Fri Apr 3 20:09:02 2020 +0100 * lisp/emacs-lisp/comp.el (native-compile): Better documentation. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index d29e2f55f1..3f4dba6b1f 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2229,6 +2229,8 @@ display a message." "Compile FUNCTION-OR-FILE into native code. This is the entry-point for the Emacs Lisp native compiler. FUNCTION-OR-FILE is a function symbol or a path to an Elisp file. +When WITH-LATE-LOAD non Nil mark the compilation unit for late load +once finished compiling (internal use only). Return the compilation unit file name." (unless (or (functionp function-or-file) (stringp function-or-file)) commit fcce8dd3614c4217ef7f908a059c0f5731517782 Merge: 9bf9550836 00f7744c1b Author: Andrea Corallo Date: Fri Apr 3 19:06:57 2020 +0100 Merge remote-tracking branch 'savannah/master' into HEAD commit 9bf9550836b526d1e72378b2a64385df8d47ac07 Author: Andrea Corallo Date: Fri Apr 3 15:35:28 2020 +0100 src/comp.c: Fix i386 In i386 ABI parameter passing of structs (and unions) is done as pointer + size. Surprisingly this is done *always* even if the structure is known to be word size. diff --git a/src/comp.c b/src/comp.c index 2aa0c47221..935b7aafda 100644 --- a/src/comp.c +++ b/src/comp.c @@ -107,7 +107,6 @@ typedef struct { gcc_jit_type *uintptr_type; gcc_jit_type *lisp_obj_type; gcc_jit_type *lisp_obj_ptr_type; - gcc_jit_field *lisp_obj_as_ptr; gcc_jit_field *lisp_obj_as_num; /* struct Lisp_Cons */ gcc_jit_struct *lisp_cons_s; @@ -671,20 +670,14 @@ static gcc_jit_rvalue * emit_XLI (gcc_jit_rvalue *obj) { emit_comment ("XLI"); - - return gcc_jit_rvalue_access_field (obj, - NULL, - comp.lisp_obj_as_num); + return obj; } static gcc_jit_lvalue * emit_lval_XLI (gcc_jit_lvalue *obj) { emit_comment ("lval_XLI"); - - return gcc_jit_lvalue_access_field (obj, - NULL, - comp.lisp_obj_as_num); + return obj; } /* @@ -3132,19 +3125,6 @@ DEFUN ("comp--init-ctxt", Fcomp__init_ctxt, Scomp__init_ctxt, comp.unsigned_long_long_type = gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_UNSIGNED_LONG_LONG); comp.char_ptr_type = gcc_jit_type_get_pointer (comp.char_type); -#if EMACS_INT_MAX <= LONG_MAX - /* 32-bit builds without wide ints, 64-bit builds on Posix hosts. */ - comp.lisp_obj_as_ptr = gcc_jit_context_new_field (comp.ctxt, - NULL, - comp.void_ptr_type, - "obj"); -#else - /* 64-bit builds on MS-Windows, 32-bit builds with wide ints. */ - comp.lisp_obj_as_ptr = gcc_jit_context_new_field (comp.ctxt, - NULL, - comp.long_long_type, - "obj"); -#endif comp.emacs_int_type = gcc_jit_context_get_int_type (comp.ctxt, sizeof (EMACS_INT), true); @@ -3152,14 +3132,9 @@ DEFUN ("comp--init-ctxt", Fcomp__init_ctxt, Scomp__init_ctxt, NULL, comp.emacs_int_type, "num"); - gcc_jit_field *lisp_obj_fields[] = { comp.lisp_obj_as_ptr, - comp.lisp_obj_as_num }; - comp.lisp_obj_type = - gcc_jit_context_new_union_type (comp.ctxt, - NULL, - "comp_Lisp_Object", - ARRAYELTS (lisp_obj_fields), - lisp_obj_fields); + /* No XLP is emitted for now so lets define this always as integer + disregarding LISP_WORDS_ARE_POINTERS value. */ + comp.lisp_obj_type = comp.emacs_int_type; comp.lisp_obj_ptr_type = gcc_jit_type_get_pointer (comp.lisp_obj_type); comp.most_positive_fixnum = gcc_jit_context_new_rvalue_from_long (comp.ctxt, commit 3cc0438629843e7dbd3bda8bbcf6578b2e7f6200 Merge: 63af801ed3 f28166dc9a Author: Andrea Corallo Date: Fri Apr 3 11:15:55 2020 +0100 Merge remote-tracking branch 'savannah/master' into HEAD commit 63af801ed34c8dc59fb13c9e058c49203a1ae55d Author: Ashish SHUKLA Date: Fri Apr 3 02:07:05 2020 +0530 configure.ac: switch to POSIX sh behaviour diff --git a/configure.ac b/configure.ac index 393a53d763..e8f4601091 100644 --- a/configure.ac +++ b/configure.ac @@ -3729,7 +3729,7 @@ if test "${with_nativecomp}" != "no"; then AC_CHECK_LIB(gccjit, gcc_jit_context_acquire, HAVE_NATIVE_COMP=yes)) if test "${HAVE_NATIVE_COMP}" = "yes"; then LIBGCCJIT_LIB="-lgccjit -ldl" - COMP_OBJ+=comp.o + COMP_OBJ="comp.o" AC_DEFINE(HAVE_NATIVE_COMP, 1, [Define to 1 if you have the libgccjit library (-lgccjit).]) else AC_MSG_ERROR([elisp native compiler requested but libgccjit not found. commit 00ee320a620704ae12a1e2104c2d08bf8bbdf0c9 Merge: 530faee275 76b3bd8cbb Author: Andrea Corallo Date: Sun Mar 29 12:31:24 2020 +0100 Merge remote-tracking branch 'savannah/master' into HEAD commit 530faee2752c7b316fa21f2ac4d1266d3e7a38e6 Author: Andrea Corallo Date: Sun Mar 29 11:21:55 2020 +0100 Fix free function compilation diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 977f137b79..b363107447 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -3120,7 +3120,8 @@ for symbols generated by the byte compiler itself." (out (list 'byte-code (byte-compile-lapcode byte-compile-output) byte-compile-vector byte-compile-maxdepth))) (when (and byte-native-compiling - (null byte-compile-not-top-level)) + (or (null byte-compile-not-top-level) + (eq byte-native-compiling 'free-func))) ;; Spill LAP for the native compiler here (push (cons byte-compile-current-form byte-compile-output) byte-to-native-lap)) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 92d0655ffd..d29e2f55f1 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -514,7 +514,8 @@ Put PREFIX in front of it." (cl-defgeneric comp-spill-lap-function ((function-name symbol)) "Byte compile FUNCTION-NAME spilling data from the byte compiler." - (let* ((f (symbol-function function-name)) + (let* ((byte-native-compiling 'free-func) + (f (symbol-function function-name)) (c-name (comp-c-func-name function-name "F")) (func (make-comp-func :name function-name :c-name c-name @@ -536,8 +537,8 @@ Put PREFIX in front of it." (comp-func-frame-size func) (comp-byte-frame-size (comp-func-byte-func func)))) (setf (comp-ctxt-top-level-forms comp-ctxt) - (list (make-byte-to-native-function :name function-name))) - (setf (byte-to-native-function-c-name func) c-name) + (list (make-byte-to-native-function :name function-name + :c-name c-name))) ;; Create the default array. (puthash 0 (comp-func-frame-size func) (comp-func-array-h func)) (comp-add-func-to-ctxt func)))) commit 53f9bc6908a4da8f5c985e8f204a479c828c432d Author: Andrea Corallo Date: Sun Mar 29 11:09:02 2020 +0100 * comp.el (comp-output-base-filename): Handle src being a symbol diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index eca61c6bac..92d0655ffd 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -440,7 +440,8 @@ VERBOSITY is a number between 0 and 3." (defun comp-output-base-filename (src) "Output filename sans extention for SRC file being native compiled." - (let* ((expanded-filename (expand-file-name src)) + (let* ((src (if (symbolp src) (symbol-name src) src)) + (expanded-filename (expand-file-name src)) (output-dir (file-name-as-directory (concat (file-name-directory expanded-filename) comp-native-path-postfix))) commit c69c185109c90ecc486ab707ed32d7bb7aa467d5 Author: Andrea Corallo Date: Sun Mar 29 10:57:36 2020 +0100 Add comp-test-40187 checking function shadowing. diff --git a/test/src/comp-test-funcs.el b/test/src/comp-test-funcs.el index 67b85753b8..9fcc132b51 100644 --- a/test/src/comp-test-funcs.el +++ b/test/src/comp-test-funcs.el @@ -272,6 +272,14 @@ (defun comp-test-interactive-form2-f () (interactive)) +(defun comp-test-40187-2-f () + 'foo) + +(defalias 'comp-test-40187-1-f (symbol-function 'comp-test-40187-2-f)) + +(defun comp-test-40187-2-f () + 'bar) + ;;;;;;;;;;;;;;;;;;;; ;; Tromey's tests ;; diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index c4f46b63dd..4768e1a1ac 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -339,6 +339,12 @@ Check that the resulting binaries do not differ." (should (equal (interactive-form #'comp-tests-free-fun-f) '(interactive)))) +(ert-deftest comp-test-40187 () + "Check function name shadowing. +https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-03/msg00914.html." + (should (eq (comp-test-40187-1-f) 'foo)) + (should (eq (comp-test-40187-2-f) 'bar))) + ;;;;;;;;;;;;;;;;;;;; ;; Tromey's tests ;; commit 89cbff32e41771a64ba62e449ec797d55f86f15c Author: Andrea Corallo Date: Sun Mar 29 10:51:12 2020 +0100 * test/src/comp-tests.el (comp-tests-doc): Fix diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index e4b7a066cc..c4f46b63dd 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -308,8 +308,7 @@ Check that the resulting binaries do not differ." (ert-deftest comp-tests-doc () (should (string= (documentation #'comp-tests-doc-f) "A nice docstring")) - (should (string= (symbol-file #'comp-tests-doc-f) - (concat comp-test-src "n")))) + (should (string-match "\\.*.eln\\'" (symbol-file #'comp-tests-doc-f)))) (ert-deftest comp-test-interactive-form () (should (equal (interactive-form #'comp-test-interactive-form0-f) commit 3c5e3ca2badeda8637e84586eace6ba619f0110a Author: Andrea Corallo Date: Sun Mar 29 10:44:11 2020 +0100 * test/src/comp-test-funcs.el (comp-test-big-interactive): New test diff --git a/test/src/comp-test-funcs.el b/test/src/comp-test-funcs.el index 46d324bc42..67b85753b8 100644 --- a/test/src/comp-test-funcs.el +++ b/test/src/comp-test-funcs.el @@ -403,6 +403,41 @@ (?< 1) (?> 2)))) +(defun comp-test-big-interactive (filename &optional force arg load) + ;; Check non trivial interactive form using `byte-recompile-file'. + (interactive + (let ((file buffer-file-name) + (file-name nil) + (file-dir nil)) + (and file + (derived-mode-p 'emacs-lisp-mode) + (setq file-name (file-name-nondirectory file) + file-dir (file-name-directory file))) + (list (read-file-name (if current-prefix-arg + "Byte compile file: " + "Byte recompile file: ") + file-dir file-name nil) + current-prefix-arg))) + (let ((dest (byte-compile-dest-file filename)) + ;; Expand now so we get the current buffer's defaults + (filename (expand-file-name filename))) + (if (if (file-exists-p dest) + ;; File was already compiled + ;; Compile if forced to, or filename newer + (or force + (file-newer-than-file-p filename dest)) + (and arg + (or (eq 0 arg) + (y-or-n-p (concat "Compile " + filename "? "))))) + (progn + (if (and noninteractive (not byte-compile-verbose)) + (message "Compiling %s..." filename)) + (byte-compile-file filename load)) + (when load + (load (if (file-exists-p dest) dest filename))) + 'no-byte-compile))) + (provide 'comp-test-funcs) ;;; comp-test-funcs.el ends here commit d5f6dc131b63d6bde096c03927c05a490c707c41 Author: Andrea Corallo Date: Sat Mar 28 20:56:47 2020 +0000 Prevent collisions in C namespace and function shadowing This rework make functions being indexed by their unique C symbol name preventing multiple lisp function with the same name colliding. diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index fe5616be66..977f137b79 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -565,7 +565,7 @@ Each element is (INDEX . VALUE)") ;; These are use by comp.el to spill data out of here (cl-defstruct byte-to-native-function "Named or anonymous function defined a top level." - name data) + name c-name data) (cl-defstruct byte-to-native-top-level "All other top level forms." form) @@ -1094,6 +1094,8 @@ message buffer `default-directory'." (defvar byte-compile-current-file nil) (defvar byte-compile-current-group nil) (defvar byte-compile-current-buffer nil) +(defvar byte-compile-not-top-level nil ; We'll evolve this for naming lambdas + "Non nil if compiling something that is not top-level.") ;; Log something that isn't a warning. (defmacro byte-compile-log (format-string &rest args) @@ -2916,6 +2918,7 @@ for symbols generated by the byte compiler itself." ;; args of `list'. Actually, compile it to get warnings, ;; but don't use the result. (let* ((form (nth 1 int)) + (byte-compile-not-top-level t) (newform (byte-compile-top-level form))) (while (memq (car-safe form) '(let let* progn save-excursion)) (while (consp (cdr form)) @@ -3116,7 +3119,8 @@ for symbols generated by the byte compiler itself." (let* ((byte-compile-vector (byte-compile-constants-vector)) (out (list 'byte-code (byte-compile-lapcode byte-compile-output) byte-compile-vector byte-compile-maxdepth))) - (when byte-native-compiling + (when (and byte-native-compiling + (null byte-compile-not-top-level)) ;; Spill LAP for the native compiler here (push (cons byte-compile-current-form byte-compile-output) byte-to-native-lap)) @@ -3170,7 +3174,8 @@ for symbols generated by the byte compiler itself." ;; byte-compile--for-effect flag too.) ;; (defun byte-compile-form (form &optional for-effect) - (let ((byte-compile--for-effect for-effect)) + (let ((byte-compile--for-effect for-effect) + (byte-compile-not-top-level t)) (cond ((not (consp form)) (cond ((or (not (symbolp form)) (macroexp--const-symbol-p form)) @@ -3944,7 +3949,8 @@ discarding." ;; and (funcall (function foo)) will lose with autoloads. (defun byte-compile-function-form (form) - (let ((f (nth 1 form))) + (let ((f (nth 1 form)) + (byte-compile-not-top-level t)) (when (and (symbolp f) (byte-compile-warning-enabled-p 'callargs f)) (byte-compile-function-warn f t (byte-compile-fdefinition f nil))) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index c5c894f660..eca61c6bac 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -208,13 +208,15 @@ Can be one of: 'd-default', 'd-impure' or 'd-ephemeral'. See `comp-ctxt'.") :documentation "Target output file-name for the compilation.") (top-level-forms () :type list :documentation "List of spilled top level forms.") - (funcs-h (make-hash-table) :type hash-table - :documentation "lisp-func-name -> comp-func. -This is to build the prev field.") + (funcs-h (make-hash-table :test #'equal) :type hash-table + :documentation "c-name -> comp-func.") + (sym-to-c-name-h (make-hash-table :test #'eq) :type hash-table + :documentation "symbol-function -> c-name. +This is only for optimizing intra CU calls at speed 3.") (d-default (make-comp-data-container) :type comp-data-container - :documentation "Standard data relocated in use by functions.") + :documentation "Standard data relocated in use by functions.") (d-impure (make-comp-data-container) :type comp-data-container - :documentation "Relocated data that cannot be moved into pure space. + :documentation "Relocated data that cannot be moved into pure space. This is tipically for top-level forms other than defun.") (d-ephemeral (make-comp-data-container) :type comp-data-container :documentation "Relocated data not necessary after load.") @@ -471,7 +473,14 @@ Put PREFIX in front of it." "-" "_" orig-name)) (human-readable (replace-regexp-in-string (rx (not (any "0-9a-z_"))) "" human-readable))) - (concat prefix crypted "_" human-readable))) + ;; Prevent C namespace conflicts. + (cl-loop + with h = (comp-ctxt-funcs-h comp-ctxt) + for i from 0 + for c-sym = (concat prefix crypted "_" human-readable "_" + (number-to-string i)) + unless (gethash c-sym h) + return c-sym))) (defun comp-decrypt-arg-list (x function-name) "Decript argument list X for FUNCTION-NAME." @@ -492,14 +501,22 @@ Put PREFIX in front of it." "Given BYTE-COMPILED-FUNC return the frame size to be allocated." (aref byte-compiled-func 3)) +(defun comp-add-func-to-ctxt (func) + "Add FUNC to the current compiler contex." + (let ((name (comp-func-name func)) + (c-name (comp-func-c-name func))) + (puthash name c-name (comp-ctxt-sym-to-c-name-h comp-ctxt)) + (puthash c-name func (comp-ctxt-funcs-h comp-ctxt)))) + (cl-defgeneric comp-spill-lap-function (input) "Byte compile INPUT and spill lap for further stages.") (cl-defgeneric comp-spill-lap-function ((function-name symbol)) "Byte compile FUNCTION-NAME spilling data from the byte compiler." (let* ((f (symbol-function function-name)) + (c-name (comp-c-func-name function-name "F")) (func (make-comp-func :name function-name - :c-name (comp-c-func-name function-name "F") + :c-name c-name :doc (documentation f) :int-spec (interactive-form f)))) (when (byte-code-function-p f) @@ -519,9 +536,10 @@ Put PREFIX in front of it." (comp-byte-frame-size (comp-func-byte-func func)))) (setf (comp-ctxt-top-level-forms comp-ctxt) (list (make-byte-to-native-function :name function-name))) + (setf (byte-to-native-function-c-name func) c-name) ;; Create the default array. (puthash 0 (comp-func-frame-size func) (comp-func-array-h func)) - (list func)))) + (comp-add-func-to-ctxt func)))) (cl-defgeneric comp-spill-lap-function ((filename string)) "Byte compile FILENAME spilling data from the byte compiler." @@ -530,28 +548,39 @@ Put PREFIX in front of it." (signal 'native-compiler-error-empty-byte filename)) (setf (comp-ctxt-top-level-forms comp-ctxt) (reverse byte-to-native-top-level-forms)) + (comp-log byte-to-native-lap 3) (cl-loop - for f in (cl-loop for x in byte-to-native-top-level-forms ; All non anonymous. + with lap-forms = (reverse byte-to-native-lap) + ;; All non anonymous functions. + for f in (cl-loop for x in (comp-ctxt-top-level-forms comp-ctxt) when (and (byte-to-native-function-p x) (byte-to-native-function-name x)) collect x) for name = (byte-to-native-function-name f) + for c-name = (comp-c-func-name name "F") + for lap-entry = (assoc name lap-forms) + for lap = (cdr lap-entry) for data = (byte-to-native-function-data f) - for lap = (alist-get name byte-to-native-lap) for func = (make-comp-func :name name :byte-func data :doc (documentation data) :int-spec (interactive-form data) - :c-name (comp-c-func-name name "F") + :c-name c-name :args (comp-decrypt-arg-list (aref data 0) name) - :lap (alist-get name byte-to-native-lap) + :lap lap :frame-size (comp-byte-frame-size data)) do - ;; Create the default array. - (puthash 0 (comp-func-frame-size func) (comp-func-array-h func)) - (comp-log (format "Function %s:\n" name) 1) - (comp-log lap 1) - collect func)) + ;; Remove it form the original lap list to avoid multiple function + ;; definition with the same name shadowing each other. + (setf lap-forms (delete lap-entry lap-forms)) + ;; Store the c-name to have it retrivable from + ;; comp-ctxt-top-level-forms. + (setf (byte-to-native-function-c-name f) c-name) + ;; Create the default array. + (puthash 0 (comp-func-frame-size func) (comp-func-array-h func)) + (comp-add-func-to-ctxt func) + (comp-log (format "Function %s:\n" name) 1) + (comp-log lap 1))) (defun comp-spill-lap (input) "Byte compile and spill the LAP representation for INPUT. @@ -1163,7 +1192,8 @@ the annotation emission." (cl-defmethod comp-emit-for-top-level ((form byte-to-native-function) for-late-load) (let* ((name (byte-to-native-function-name form)) - (f (gethash name (comp-ctxt-funcs-h comp-ctxt))) + (c-name (byte-to-native-function-c-name form)) + (f (gethash c-name (comp-ctxt-funcs-h comp-ctxt))) (args (comp-func-args f))) (cl-assert (and name f)) (comp-emit (comp-call (if for-late-load @@ -1174,7 +1204,7 @@ the annotation emission." (make-comp-mvar :constant (if (comp-args-p args) (comp-args-max args) 'many)) - (make-comp-mvar :constant (comp-func-c-name f)) + (make-comp-mvar :constant c-name) (make-comp-mvar :constant (comp-func-doc f)) (make-comp-mvar :constant (comp-func-int-spec f)) @@ -1301,16 +1331,10 @@ into the C code forwarding the compilation unit." (puthash addr t addr-h)) (comp-limplify-finalize-function func))) -(defun comp-add-func-to-ctxt (func) - "Add FUNC to the current compiler contex." - (puthash (comp-func-name func) - func - (comp-ctxt-funcs-h comp-ctxt))) - -(defun comp-limplify (lap-funcs) - "Compute the LIMPLE ir for LAP-FUNCS. -Top-level forms for the current context are rendered too." - (mapc #'comp-add-func-to-ctxt (mapcar #'comp-limplify-function lap-funcs)) +(defun comp-limplify (_) + "Compute LIMPLE IR for forms in `comp-ctxt'." + (maphash (lambda (_ f) (comp-limplify-function f)) + (comp-ctxt-funcs-h comp-ctxt)) (comp-add-func-to-ctxt (comp-limplify-top-level nil)) (when (comp-ctxt-with-late-load comp-ctxt) (comp-add-func-to-ctxt (comp-limplify-top-level t)))) @@ -1843,7 +1867,8 @@ Backward propagate array placement properties." (not (memq callee comp-never-optimize-functions))) (let* ((f (symbol-function callee)) (subrp (subrp f)) - (callee-in-unit (gethash callee + (callee-in-unit (gethash (gethash callee + (comp-ctxt-sym-to-c-name-h comp-ctxt)) (comp-ctxt-funcs-h comp-ctxt)))) (cond ((and subrp (not (subr-native-elisp-p f))) diff --git a/src/comp.c b/src/comp.c index 563f625073..2aa0c47221 100644 --- a/src/comp.c +++ b/src/comp.c @@ -174,7 +174,7 @@ typedef struct { gcc_jit_function *check_type; gcc_jit_function *check_impure; Lisp_Object func_blocks_h; /* blk_name -> gcc_block. */ - Lisp_Object exported_funcs_h; /* subr_name -> gcc_jit_function *. */ + Lisp_Object exported_funcs_h; /* c-func-name -> gcc_jit_function *. */ Lisp_Object imported_funcs_h; /* subr_name -> gcc_jit_field *reloc_field. */ Lisp_Object emitter_dispatcher; /* Synthesized struct holding data relocs. */ @@ -518,9 +518,18 @@ static gcc_jit_rvalue * emit_call (Lisp_Object subr_sym, gcc_jit_type *ret_type, ptrdiff_t nargs, gcc_jit_rvalue **args, bool direct) { - Lisp_Object func = - Fgethash (subr_sym, direct ? comp.exported_funcs_h: comp.imported_funcs_h, - Qnil); + Lisp_Object func; + if (direct) + { + Lisp_Object c_name = + Fgethash (subr_sym, + CALL1I (comp-ctxt-sym-to-c-name-h, Vcomp_ctxt), + Qnil); + func = Fgethash (c_name, comp.exported_funcs_h, Qnil); + } + else + func = Fgethash (subr_sym, comp.imported_funcs_h, Qnil); + if (NILP (func)) xsignal2 (Qnative_ice, build_string ("missing function declaration"), @@ -2926,7 +2935,7 @@ declare_function (Lisp_Object func) c_name, 2, param, 0); } - Fputhash (CALL1I (comp-func-name, func), + Fputhash (CALL1I (comp-func-c-name, func), make_mint_ptr (gcc_func), comp.exported_funcs_h); @@ -2939,7 +2948,7 @@ compile_function (Lisp_Object func) USE_SAFE_ALLOCA; EMACS_INT frame_size = XFIXNUM (CALL1I (comp-func-frame-size, func)); - comp.func = xmint_pointer (Fgethash (CALL1I (comp-func-name, func), + comp.func = xmint_pointer (Fgethash (CALL1I (comp-func-c-name, func), comp.exported_funcs_h, Qnil)); comp.func_has_non_local = !NILP (CALL1I (comp-func-has-non-local, func)); @@ -3179,7 +3188,7 @@ DEFUN ("comp--init-ctxt", Fcomp__init_ctxt, Scomp__init_ctxt, sizeof (void *), false); - comp.exported_funcs_h = CALLN (Fmake_hash_table); + comp.exported_funcs_h = CALLN (Fmake_hash_table, QCtest, Qequal); /* Always reinitialize this cause old function definitions are garbage collected by libgccjit when the ctxt is released. commit 9d8ce520f03217e5aaf08b3e252a1bb82c3fc641 Author: Andrea Corallo Date: Thu Mar 26 15:47:36 2020 +0000 * comp.c (maybe_defer_native_compilation): Compile comp dependecies. Make maybe_defer_native_compilation able to compile comp dependecies breaking circularity. diff --git a/src/comp.c b/src/comp.c index 60ef3bf0dc..563f625073 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3356,6 +3356,10 @@ helper_PSEUDOVECTOR_TYPEP_XUNTAG (Lisp_Object a, enum pvec_type code) /* Deferred compilation mechanism. */ /***********************************/ +/* List of sources we'll compile and load after having conventionally + loaded the compiler and its dependencies. */ +static Lisp_Object delayed_sources; + void maybe_defer_native_compilation (Lisp_Object function_name, Lisp_Object definition) @@ -3396,13 +3400,32 @@ maybe_defer_native_compilation (Lisp_Object function_name, if (NILP (Ffile_exists_p (src))) return; - /* Really happening. */ - Fputhash (function_name, definition, Vcomp_deferred_pending_h); - comp_deferred_compilation = false; - Frequire (intern_c_string ("comp"), Qnil, Qnil); - comp_deferred_compilation = true; - CALLN (Ffuncall, intern_c_string ("native-compile-async"), src, Qnil, - Qlate); + /* This is to have deferred compilaiton able to compile comp + dependecies breaking circularity. */ + if (!NILP (Ffeaturep (Qcomp, Qnil))) + { + /* Comp already loaded. */ + if (!NILP (delayed_sources)) + { + CALLN (Ffuncall, intern_c_string ("native-compile-async"), + delayed_sources, Qnil, Qlate); + delayed_sources = Qnil; + } + Fputhash (function_name, definition, Vcomp_deferred_pending_h); + CALLN (Ffuncall, intern_c_string ("native-compile-async"), src, Qnil, + Qlate); + } + else + { + delayed_sources = Fcons (src, delayed_sources); + /* Require comp only once. */ + static bool comp_required = false; + if (!comp_required) + { + comp_required = true; + Frequire (Qcomp, Qnil, Qnil); + } + } } @@ -3675,6 +3698,7 @@ syms_of_comp (void) DEFSYM (Qd_ephemeral, "d-ephemeral"); /* Others. */ + DEFSYM (Qcomp, "comp"); DEFSYM (Qfixnum, "fixnum"); DEFSYM (Qscratch, "scratch"); DEFSYM (Qlate, "late"); @@ -3733,6 +3757,8 @@ syms_of_comp (void) staticpro (&comp.func_blocks_h); staticpro (&comp.emitter_dispatcher); comp.emitter_dispatcher = Qnil; + staticpro (&delayed_sources); + delayed_sources = Qnil; DEFVAR_LISP ("comp-ctxt", Vcomp_ctxt, doc: /* The compiler context. */); commit 05f89e8ef4eb5fbcd04fcc9c0dcb92f90ad6b28c Author: Andrea Corallo Date: Sun Mar 29 12:26:45 2020 +0100 src/comp.c (Fcomp__init_ctxt): Aesthetic diff --git a/src/comp.c b/src/comp.c index d72d6acc8e..60ef3bf0dc 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3123,7 +3123,6 @@ DEFUN ("comp--init-ctxt", Fcomp__init_ctxt, Scomp__init_ctxt, comp.unsigned_long_long_type = gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_UNSIGNED_LONG_LONG); comp.char_ptr_type = gcc_jit_type_get_pointer (comp.char_type); - #if EMACS_INT_MAX <= LONG_MAX /* 32-bit builds without wide ints, 64-bit builds on Posix hosts. */ comp.lisp_obj_as_ptr = gcc_jit_context_new_field (comp.ctxt, @@ -3137,16 +3136,13 @@ DEFUN ("comp--init-ctxt", Fcomp__init_ctxt, Scomp__init_ctxt, comp.long_long_type, "obj"); #endif - comp.emacs_int_type = gcc_jit_context_get_int_type (comp.ctxt, sizeof (EMACS_INT), true); - comp.lisp_obj_as_num = gcc_jit_context_new_field (comp.ctxt, NULL, comp.emacs_int_type, "num"); - gcc_jit_field *lisp_obj_fields[] = { comp.lisp_obj_as_ptr, comp.lisp_obj_as_num }; comp.lisp_obj_type = @@ -3156,7 +3152,6 @@ DEFUN ("comp--init-ctxt", Fcomp__init_ctxt, Scomp__init_ctxt, ARRAYELTS (lisp_obj_fields), lisp_obj_fields); comp.lisp_obj_ptr_type = gcc_jit_type_get_pointer (comp.lisp_obj_type); - comp.most_positive_fixnum = gcc_jit_context_new_rvalue_from_long (comp.ctxt, comp.emacs_int_type, @@ -3173,16 +3168,13 @@ DEFUN ("comp--init-ctxt", Fcomp__init_ctxt, Scomp__init_ctxt, gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.emacs_int_type, INTTYPEBITS); - comp.lisp_int0 = gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.emacs_int_type, Lisp_Int0); - comp.ptrdiff_type = gcc_jit_context_get_int_type (comp.ctxt, sizeof (void *), true); - comp.uintptr_type = gcc_jit_context_get_int_type (comp.ctxt, sizeof (void *), false); commit 79483a5873a90bb28178af59acfdb00040c3d23d Author: Andrea Corallo Date: Tue Mar 24 20:36:46 2020 +0000 * .gitlab-ci.yml (test-native-bootstrap-speed*): Timeout to 8h Running in tests in parall takes longer. diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index ae46481e1a..4522bb6bb4 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -81,7 +81,7 @@ test-native-bootstrap-speed0: - ./autogen.sh autoconf - ./configure --without-makeinfo --with-nativecomp - make bootstrap BYTE_COMPILE_EXTRA_FLAGS='--eval "(setq comp-speed 0)"' -j2 - timeout: 3 hours + timeout: 8 hours test-native-bootstrap-speed1: stage: test @@ -90,7 +90,7 @@ test-native-bootstrap-speed1: - ./autogen.sh autoconf - ./configure --without-makeinfo --with-nativecomp - make bootstrap NATIVE_FAST_BOOT=1 BYTE_COMPILE_EXTRA_FLAGS='--eval "(setq comp-speed 1)"' - timeout: 6 hours + timeout: 8 hours test-native-bootstrap-speed2: stage: test @@ -99,4 +99,4 @@ test-native-bootstrap-speed2: - ./autogen.sh autoconf - ./configure --without-makeinfo --with-nativecomp - make bootstrap NATIVE_FAST_BOOT=1 - timeout: 6 hours + timeout: 8 hours commit bb0496e7e55a7fca89c51eb0b85dcfa6904ea3ec Author: Andrea Corallo Date: Tue Mar 24 18:47:39 2020 +0000 * comp.c (emit_mvar_access): Fix speed 1 compilation At speed 1 propagate does not run and all mvars are allocated in array 0. diff --git a/src/comp.c b/src/comp.c index 3205a29a10..d72d6acc8e 100644 --- a/src/comp.c +++ b/src/comp.c @@ -388,7 +388,7 @@ emit_mvar_access (Lisp_Object mvar) EMACS_INT arr_idx = XFIXNUM (CALL1I (comp-mvar-array-idx, mvar)); EMACS_INT slot_n = XFIXNUM (mvar_slot); - if (comp.func_has_non_local || !SPEED) + if (comp.func_has_non_local || (SPEED < 2)) return comp.arrays[arr_idx][slot_n]; else { commit 4acc4ac66753ff1556be907f2611b48ffc3fc79c Author: Andrea Corallo Date: Tue Mar 24 19:10:20 2020 +0000 * comp.el (native-compile-async): Fix excessive messaging diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index dfa9658a36..c5c894f660 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2283,8 +2283,8 @@ LOAD can be nil t or 'late." file) (setf comp-files-queue (append comp-files-queue `((,file . ,load)))))) (when (zerop (comp-async-runnings)) - (comp-run-async-workers)) - (message "Compilation started."))) + (comp-run-async-workers) + (message "Compilation started.")))) (provide 'comp) commit f7e10297d18b17f55b4a8442a3307db00605d46d Merge: 73ced8c23e 82f8bee734 Author: Andrea Corallo Date: Tue Mar 24 16:22:06 2020 +0000 Merge remote-tracking branch 'savannah/master' into HEAD commit 73ced8c23ec3d5cdfa6d926af649235104707d85 Author: Andrea Corallo Date: Mon Mar 23 22:27:17 2020 +0000 * comp.el : Fix typo introduced by f8b07ff4f3 diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index c6f2ca13aa..dfa9658a36 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2191,7 +2191,7 @@ display a message." (insert msg "\n"))) ;; `comp-deferred-pending-h' should be empty at this stage. ;; Reset it anyway. - (setf comp-deferred-pending-h (make-hash-table :equal #'eq)) + (setf comp-deferred-pending-h (make-hash-table :test #'eq)) (message msg)))) commit 8cc8adb04d2861fb1b1bbb38e53feccf3a2fc1c5 Merge: f8b07ff4f3 5d5d5d492c Author: Andrea Corallo Date: Mon Mar 23 20:38:07 2020 +0000 Merge remote-tracking branch 'savannah/master' into HEAD commit f8b07ff4f318d799a471c9363903e3929fd5c844 Author: Andrea Corallo Date: Mon Mar 23 15:57:48 2020 +0000 Guard against function redefinition during deferred load diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 273b41f542..c6f2ca13aa 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1160,12 +1160,15 @@ the annotation emission." (cl-defgeneric comp-emit-for-top-level (form for-late-load) "Emit the limple code for top level FORM.") -(cl-defmethod comp-emit-for-top-level ((form byte-to-native-function) _) +(cl-defmethod comp-emit-for-top-level ((form byte-to-native-function) + for-late-load) (let* ((name (byte-to-native-function-name form)) (f (gethash name (comp-ctxt-funcs-h comp-ctxt))) (args (comp-func-args f))) (cl-assert (and name f)) - (comp-emit (comp-call 'comp--register-subr + (comp-emit (comp-call (if for-late-load + 'comp--late-register-subr + 'comp--register-subr) (make-comp-mvar :constant name) (make-comp-mvar :constant (comp-args-base-min args)) (make-comp-mvar :constant (if (comp-args-p args) @@ -2186,6 +2189,9 @@ display a message." (save-excursion (goto-char (point-max)) (insert msg "\n"))) + ;; `comp-deferred-pending-h' should be empty at this stage. + ;; Reset it anyway. + (setf comp-deferred-pending-h (make-hash-table :equal #'eq)) (message msg)))) diff --git a/src/comp.c b/src/comp.c index b563f27da8..3205a29a10 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3401,14 +3401,16 @@ maybe_defer_native_compilation (Lisp_Object function_name, Lisp_Object src = concat2 (CALL1I (file-name-sans-extension, Vload_file_name), build_pure_c_string (".el")); - if (!NILP (Ffile_exists_p (src))) - { - comp_deferred_compilation = false; - Frequire (intern_c_string ("comp"), Qnil, Qnil); - comp_deferred_compilation = true; - CALLN (Ffuncall, intern_c_string ("native-compile-async"), src, Qnil, - Qlate); - } + if (NILP (Ffile_exists_p (src))) + return; + + /* Really happening. */ + Fputhash (function_name, definition, Vcomp_deferred_pending_h); + comp_deferred_compilation = false; + Frequire (intern_c_string ("comp"), Qnil, Qnil); + comp_deferred_compilation = true; + CALLN (Ffuncall, intern_c_string ("native-compile-async"), src, Qnil, + Qlate); } @@ -3584,6 +3586,21 @@ DEFUN ("comp--register-subr", Fcomp__register_subr, Scomp__register_subr, return Qnil; } +DEFUN ("comp--late-register-subr", Fcomp__late_register_subr, + Scomp__late_register_subr, 7, 7, 0, + doc: /* This gets called by late_top_level_run during load + phase to register each exported subr. */) + (Lisp_Object name, Lisp_Object minarg, Lisp_Object maxarg, + Lisp_Object c_name, Lisp_Object doc, Lisp_Object intspec, + Lisp_Object comp_u) +{ + if (!NILP (Fequal (Fsymbol_function (name), + Fgethash (name, Vcomp_deferred_pending_h, Qnil)))) + Fcomp__register_subr (name, minarg, maxarg, c_name, doc, intspec, comp_u); + Fremhash (name, Vcomp_deferred_pending_h); + return Qnil; +} + /* Load related routines. */ DEFUN ("native-elisp-load", Fnative_elisp_load, Snative_elisp_load, 1, 2, 0, doc: /* Load native elisp code FILE. @@ -3714,6 +3731,7 @@ syms_of_comp (void) defsubr (&Scomp__release_ctxt); defsubr (&Scomp__compile_ctxt_to_file); defsubr (&Scomp__register_subr); + defsubr (&Scomp__late_register_subr); defsubr (&Snative_elisp_load); staticpro (&comp.exported_funcs_h); @@ -3742,6 +3760,11 @@ syms_of_comp (void) DEFVAR_LISP ("comp-native-path-postfix", Vcomp_native_path_postfix, doc: /* Postifix to be added to the .eln compilation path. */); Vcomp_native_path_postfix = Qnil; + + DEFVAR_LISP ("comp-deferred-pending-h", Vcomp_deferred_pending_h, + doc: /* Hash table symbol-name -> function-value. For + internal use during */); + Vcomp_deferred_pending_h = CALLN (Fmake_hash_table, QCtest, Qeq); } #endif /* HAVE_NATIVE_COMP */ commit eb1d22b136a3f7a49b4060553b79ee188f55a498 Merge: 855940df6b 813478c855 Author: Andrea Corallo Date: Sun Mar 22 16:11:53 2020 +0000 Merge remote-tracking branch 'savannah/master' into HEAD commit 855940df6bde5ed41ed55336a3ac6f6ae0c6267e Author: Andrea Corallo Date: Sun Mar 22 15:08:58 2020 +0000 * comp.c (maybe_defer_native_compilation): Fix Prevent recursive compilation while deferring compilation. diff --git a/src/comp.c b/src/comp.c index f5961c7d2b..b563f27da8 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3402,8 +3402,13 @@ maybe_defer_native_compilation (Lisp_Object function_name, concat2 (CALL1I (file-name-sans-extension, Vload_file_name), build_pure_c_string (".el")); if (!NILP (Ffile_exists_p (src))) - CALLN (Ffuncall, intern_c_string ("native-compile-async"), src, Qnil, - Qlate); + { + comp_deferred_compilation = false; + Frequire (intern_c_string ("comp"), Qnil, Qnil); + comp_deferred_compilation = true; + CALLN (Ffuncall, intern_c_string ("native-compile-async"), src, Qnil, + Qlate); + } } commit 07e314569b743cfc38b8bb3599355161c576ff32 Author: Andrea Corallo Date: Sun Mar 22 14:50:01 2020 +0000 * comp.c (maybe_defer_native_compilation): Add some debug code diff --git a/src/comp.c b/src/comp.c index 55e6e96ec8..f5961c7d2b 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3368,6 +3368,27 @@ void maybe_defer_native_compilation (Lisp_Object function_name, Lisp_Object definition) { +#if 0 +#include +#include + if (!NILP (function_name) && + STRINGP (Vload_file_name)) + { + static FILE *f; + if (!f) + { + char str[128]; + sprintf (str, "log_%d", getpid()); + f = fopen (str, "w"); + } + if (!f) + exit (1); + fprintf (f, "function %s file %s\n", + SSDATA (Fsymbol_name (function_name)), + SSDATA (Vload_file_name)); + fflush (f); + } +#endif if (!comp_deferred_compilation || noninteractive || !NILP (Vpurify_flag) commit ef30feb554d29d9dd1514ceae1711938dae538b5 Author: Andrea Corallo Date: Sun Mar 22 09:35:55 2020 +0000 * comp.el: Add missing require diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index a316d741a2..273b41f542 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -32,6 +32,7 @@ (require 'cl-extra) (require 'cl-lib) (require 'cl-macs) +(require 'cl-seq) (require 'gv) (require 'rx) (require 'subr-x) commit ab4fff52d41e62d0d05a195798cb167eedf84ba6 Author: Andrea Corallo Date: Sat Mar 21 19:32:01 2020 +0000 * .gitlab-ci.yml: CI test native bootstrap speed1 and speed2 Do just a fast bootstrap for these two. diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index fa613bb412..ae46481e1a 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -69,8 +69,8 @@ test-filenotify-gio: - make bootstrap - make -C test autorevert-tests filenotify-tests -test-native-bootstrap: - # Test native bootstrap +test-native-bootstrap-speed0: + # Test a full native bootstrap # Run for now only speed 0 to limit memory usage and compilation time. stage: test # Uncomment the following to run it only when sceduled. @@ -82,3 +82,21 @@ test-native-bootstrap: - ./configure --without-makeinfo --with-nativecomp - make bootstrap BYTE_COMPILE_EXTRA_FLAGS='--eval "(setq comp-speed 0)"' -j2 timeout: 3 hours + +test-native-bootstrap-speed1: + stage: test + script: + - DEBIAN_FRONTEND=noninteractive apt install --no-install-recommends -y -qq -o=Dpkg::Use-Pty=0 libgccjit-6-dev + - ./autogen.sh autoconf + - ./configure --without-makeinfo --with-nativecomp + - make bootstrap NATIVE_FAST_BOOT=1 BYTE_COMPILE_EXTRA_FLAGS='--eval "(setq comp-speed 1)"' + timeout: 6 hours + +test-native-bootstrap-speed2: + stage: test + script: + - DEBIAN_FRONTEND=noninteractive apt install --no-install-recommends -y -qq -o=Dpkg::Use-Pty=0 libgccjit-6-dev + - ./autogen.sh autoconf + - ./configure --without-makeinfo --with-nativecomp + - make bootstrap NATIVE_FAST_BOOT=1 + timeout: 6 hours commit e05a62a968e688533f014ac556a8b32662b32ed3 Author: Andrea Corallo Date: Sat Mar 21 14:11:41 2020 +0000 Have a fast build option triggered by env var NATIVE_FAST_BOOT diff --git a/lisp/Makefile.in b/lisp/Makefile.in index 8ba619656d..035720b49b 100644 --- a/lisp/Makefile.in +++ b/lisp/Makefile.in @@ -351,9 +351,11 @@ compile-main: gen-lisp compile-clean GREP_OPTIONS= grep '^;.*[^a-zA-Z]no-byte-compile: *t' $$el > /dev/null && \ continue; \ echo "$${el}c"; \ - done | xargs $(XARGS_LIMIT) echo) | \ - while read chunk; do \ - $(MAKE) compile-targets TARGETS="$$chunk"; \ + done | xargs $(XARGS_LIMIT) echo) | \ + while read chunk; do \ + $(MAKE) compile-targets \ + NATIVE_DISABLE=$(NATIVE_FAST_BOOT) \ + TARGETS="$$chunk"; \ done .PHONY: native-compile-clean diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 1e348c065b..a316d741a2 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2234,16 +2234,18 @@ Ultra cheap impersonation of `batch-byte-compile'." (defun batch-byte-native-compile-for-bootstrap () "As `batch-byte-compile' but used for booststrap. Always generate elc files too and handle native compiler expected errors." - (let ((byte-native-for-bootstrap t) - (byte-to-native-output-file nil)) - (unwind-protect - (condition-case _ - (batch-native-compile) - (native-compiler-error-dyn-func) - (native-compiler-error-empty-byte)) - (pcase byte-to-native-output-file - (`(,tempfile . ,target-file) - (rename-file tempfile target-file t)))))) + (if (equal (getenv "NATIVE_DISABLE") "1") + (batch-byte-compile) + (let ((byte-native-for-bootstrap t) + (byte-to-native-output-file nil)) + (unwind-protect + (condition-case _ + (batch-native-compile) + (native-compiler-error-dyn-func) + (native-compiler-error-empty-byte)) + (pcase byte-to-native-output-file + (`(,tempfile . ,target-file) + (rename-file tempfile target-file t))))))) ;;;###autoload (defun native-compile-async (paths &optional recursively load) commit 64a6709f648f4f6363e1d9d63cc4fc33ff5e0340 Author: Andrea Corallo Date: Thu Mar 19 18:37:32 2020 +0000 * comp.el (comp-async-jobs-number): Fix customize type. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 00883a3568..1e348c065b 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -95,7 +95,7 @@ performed at `comp-speed' > 0." (defcustom comp-async-jobs-number 0 "Default number of processes used for async compilation. When zero use half of the CPUs or at least one." - :type 'fixnum + :type 'number :group 'comp) (defcustom comp-async-cu-done-hook nil commit 981cc1575096849f70bc381e096ac5ba274a2c2f Merge: b070571f93 0128375a50 Author: Andrea Corallo Date: Thu Mar 19 16:49:55 2020 +0000 Merge remote-tracking branch 'savannah/master' into HEAD commit b070571f93def7892b71a711a59bbd065c554897 Author: Andrea Corallo Date: Wed Mar 18 20:16:05 2020 +0000 * comp.el (comp-run-async-workers): Load only if compilation succeed diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 44de2745c6..00883a3568 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2163,16 +2163,18 @@ display a message." (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) - (when load1 - (native-elisp-load - (comp-output-filename source-file1) - load1)) - (comp-run-async-workers))))) + :sentinel + (lambda (process _event) + (run-hook-with-args + 'comp-async-cu-done-hook + source-file) + (accept-process-output process) + (when (and load1 + (zerop (process-exit-status process))) + (native-elisp-load + (comp-output-filename source-file1) + load1)) + (comp-run-async-workers))))) (push process comp-async-processes)) when (>= (comp-async-runnings) (comp-effective-async-max-jobs)) do (cl-return))) commit 0179d95630ff5864c14b8dfcefaa131ecd44c1e2 Author: Andrea Corallo Date: Wed Mar 18 20:00:43 2020 +0000 * comp.c (native-elisp-load): Guard against misisng file. diff --git a/src/comp.c b/src/comp.c index d645b59590..55e6e96ec8 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3566,7 +3566,9 @@ DEFUN ("native-elisp-load", Fnative_elisp_load, Snative_elisp_load, 1, 2, 0, (Lisp_Object file, Lisp_Object late_load) { CHECK_STRING (file); - + if (NILP (Ffile_exists_p (file))) + xsignal2 (Qnative_lisp_load_failed, build_string ("file does not exists"), + file); struct Lisp_Native_Comp_Unit *comp_u = allocate_native_comp_unit(); comp_u->handle = dynlib_open (SSDATA (file)); if (!comp_u->handle) commit 7565a4a1170bf36352ffd7283c18ac1843ae8123 Author: Andrea Corallo Date: Wed Mar 18 21:20:52 2020 +0000 Command late load when deferring compilation diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index f1e99c5ee1..44de2745c6 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -41,7 +41,9 @@ :group 'lisp) (defcustom comp-deferred-compilation nil - "If t compile asyncronously all lexically bound .elc files being loaded." + "If t compile asyncronously all lexically bound .elc files being loaded. +Once compilation happened each function definition is updated to +the native compiled one." :type 'boolean :group 'comp) diff --git a/src/comp.c b/src/comp.c index 3f2b45c85f..d645b59590 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3381,7 +3381,8 @@ maybe_defer_native_compilation (Lisp_Object function_name, concat2 (CALL1I (file-name-sans-extension, Vload_file_name), build_pure_c_string (".el")); if (!NILP (Ffile_exists_p (src))) - CALLN (Ffuncall, intern_c_string ("native-compile-async"), src, Qnil); + CALLN (Ffuncall, intern_c_string ("native-compile-async"), src, Qnil, + Qlate); } @@ -3639,6 +3640,7 @@ syms_of_comp (void) /* Others. */ DEFSYM (Qfixnum, "fixnum"); DEFSYM (Qscratch, "scratch"); + DEFSYM (Qlate, "late"); /* To be signaled by the compiler. */ DEFSYM (Qnative_compiler_error, "native-compiler-error"); commit c3e640bfa6623234e6757e1ffef1b0d6a3144ff8 Author: Andrea Corallo Date: Wed Mar 18 19:52:36 2020 +0000 * comp.el: Extend `native-compile-async' for load and late-load diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index d077fa5999..f1e99c5ee1 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -433,6 +433,21 @@ VERBOSITY is a number between 0 and 3." 2)) edges))) +(defun comp-output-base-filename (src) + "Output filename sans extention for SRC file being native compiled." + (let* ((expanded-filename (expand-file-name src)) + (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))) + +(defun comp-output-filename (src) + "Output filename for SRC file being native compiled." + (concat (comp-output-base-filename src) ".eln")) + ;;; spill-lap pass specific code. @@ -2122,7 +2137,7 @@ display a message." (> (comp-async-runnings) 0)) (unless (>= (comp-async-runnings) (comp-effective-async-max-jobs)) (cl-loop - for source-file = (pop comp-files-queue) + for (source-file . load) = (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" @@ -2136,7 +2151,9 @@ display a message." comp-verbose ,comp-verbose load-path ',load-path) (message "Compiling %s..." ,source-file) - (native-compile ,source-file))) + (native-compile ,source-file ,(and load t)))) + (source-file1 source-file) ;; Make the closure works :/ + (load1 load) (process (make-process :name (concat "Compiling: " source-file) :buffer (get-buffer-create comp-async-buffer-name) @@ -2149,6 +2166,10 @@ display a message." 'comp-async-cu-done-hook source-file) (accept-process-output process) + (when load1 + (native-elisp-load + (comp-output-filename source-file1) + load1)) (comp-run-async-workers))))) (push process comp-async-processes)) when (>= (comp-async-runnings) (comp-effective-async-max-jobs)) @@ -2181,17 +2202,7 @@ Return the compilation unit file name." (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))) + :output (comp-output-base-filename function-or-file) :with-late-load with-late-load))) (comp-log "\n \n" 1) (condition-case err @@ -2231,12 +2242,15 @@ Always generate elc files too and handle native compiler expected errors." (rename-file tempfile target-file t)))))) ;;;###autoload -(defun native-compile-async (paths recursively) +(defun native-compile-async (paths &optional recursively load) "Compile PATHS asynchronously. PATHS is one path or a list of paths to files or directories. `comp-async-jobs-number' specifies the number of (commands) to run simultaneously. If RECURSIVELY, recurse into subdirectories -of given directories." +of given directories. +LOAD can be nil t or 'late." + (unless (member load '(nil t late)) + (error "LOAD must be nil t or 'late")) (unless (listp paths) (setf paths (list paths))) (let (files) @@ -2250,7 +2264,11 @@ of given directories." (t (signal 'native-compiler-error (list "Path not a file nor directory" path))))) (dolist (file files) - (add-to-list 'comp-files-queue file t)) + (if-let ((entry (cl-find file comp-files-queue :key #'car :test #'string=))) + (cl-assert (eq load (cdr entry)) + nil "Incoherent load kind in compilation queue for %s" + file) + (setf comp-files-queue (append comp-files-queue `((,file . ,load)))))) (when (zerop (comp-async-runnings)) (comp-run-async-workers)) (message "Compilation started."))) commit b53fc68535211a59fde7200713340d911b48ecec Author: Andrea Corallo Date: Wed Mar 18 19:48:50 2020 +0000 Extend low level code for late load diff --git a/src/comp.c b/src/comp.c index 74b74a83b7..3f2b45c85f 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3368,27 +3368,18 @@ void maybe_defer_native_compilation (Lisp_Object function_name, Lisp_Object definition) { - Lisp_Object src = Qnil; - Lisp_Object load_list = Vcurrent_load_list; - - FOR_EACH_TAIL (load_list) - { - src = XCAR (load_list); - if (!CONSP (src)) - break; - } - if (!comp_deferred_compilation || noninteractive || !NILP (Vpurify_flag) || !COMPILEDP (definition) || !FIXNUMP (AREF (definition, COMPILED_ARGLIST)) - || !STRINGP (src) - || !suffix_p (src, ".elc")) + || !STRINGP (Vload_file_name) + || !suffix_p (Vload_file_name, ".elc")) return; - src = concat2 (CALL1I (file-name-sans-extension, src), - build_pure_c_string (".el")); + Lisp_Object src = + concat2 (CALL1I (file-name-sans-extension, Vload_file_name), + build_pure_c_string (".el")); if (!NILP (Ffile_exists_p (src))) CALLN (Ffuncall, intern_c_string ("native-compile-async"), src, Qnil); } @@ -3413,7 +3404,8 @@ load_static_obj (struct Lisp_Native_Comp_Unit *comp_u, const char *name) } void -load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u, bool loading_dump) +load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u, bool loading_dump, + bool late_load) { dynlib_handle_ptr handle = comp_u->handle; Lisp_Object comp_u_lisp_obj; @@ -3447,7 +3439,9 @@ load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u, bool loading_dump) freloc_check_fill (); - void (*top_level_run)(Lisp_Object) = dynlib_sym (handle, "top_level_run"); + void (*top_level_run)(Lisp_Object) + = dynlib_sym (handle, + late_load ? "late_top_level_run" : "top_level_run"); if (!reloading_cu) { @@ -3564,9 +3558,11 @@ DEFUN ("comp--register-subr", Fcomp__register_subr, Scomp__register_subr, } /* Load related routines. */ -DEFUN ("native-elisp-load", Fnative_elisp_load, Snative_elisp_load, 1, 1, 0, - doc: /* Load native elisp code FILE. */) - (Lisp_Object file) +DEFUN ("native-elisp-load", Fnative_elisp_load, Snative_elisp_load, 1, 2, 0, + doc: /* Load native elisp code FILE. + LATE_LOAD has to be non nil when loading for deferred + compilation. */) + (Lisp_Object file, Lisp_Object late_load) { CHECK_STRING (file); @@ -3576,7 +3572,7 @@ DEFUN ("native-elisp-load", Fnative_elisp_load, Snative_elisp_load, 1, 1, 0, xsignal2 (Qnative_lisp_load_failed, file, build_string (dynlib_error ())); comp_u->file = file; comp_u->data_vec = Qnil; - load_comp_unit (comp_u, false); + load_comp_unit (comp_u, false, !NILP (late_load)); return Qt; } diff --git a/src/comp.h b/src/comp.h index f3bcd4c09b..f5baa88853 100644 --- a/src/comp.h +++ b/src/comp.h @@ -64,8 +64,8 @@ XNATIVE_COMP_UNIT (Lisp_Object a) extern void hash_native_abi (void); -extern void load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u, - bool loading_dump); +void load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u, bool loading_dump, + bool late_load); extern void syms_of_comp (void); extern void maybe_defer_native_compilation (Lisp_Object function_name, diff --git a/src/lread.c b/src/lread.c index 2d90bccdc0..b2f437130c 100644 --- a/src/lread.c +++ b/src/lread.c @@ -1483,7 +1483,7 @@ Return t if the file exists and loads successfully. */) { specbind (Qcurrent_load_list, Qnil); LOADHIST_ATTACH (found); - Fnative_elisp_load (found); + Fnative_elisp_load (found, Qnil); build_load_history (found, true); } else diff --git a/src/pdumper.c b/src/pdumper.c index 2e2220a9b2..55f95fd0e7 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -5303,7 +5303,7 @@ dump_do_dump_relocation (const uintptr_t dump_base, comp_u->handle = dynlib_open (SSDATA (comp_u->file)); if (!comp_u->handle) error ("%s", dynlib_error ()); - load_comp_unit (comp_u, true); + load_comp_unit (comp_u, true, false); break; } case RELOC_NATIVE_SUBR: commit 034d9b319c2d596d090364476a193fbc409026d6 Author: Andrea Corallo Date: Tue Mar 17 22:24:52 2020 +0000 * comp.el: late-load support optional as `native-compile' parameter diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 3a56876cc0..d077fa5999 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -214,7 +214,9 @@ This is to build the prev field.") :documentation "Relocated data that cannot be moved into pure space. This is tipically for top-level forms other than defun.") (d-ephemeral (make-comp-data-container) :type comp-data-container - :documentation "Relocated data not necessary after load.")) + :documentation "Relocated data not necessary after load.") + (with-late-load nil :type boolean + :documentation "When non nil support late load.")) (cl-defstruct comp-args-base (min nil :type number @@ -1289,7 +1291,8 @@ into the C code forwarding the compilation unit." Top-level forms for the current context are rendered too." (mapc #'comp-add-func-to-ctxt (mapcar #'comp-limplify-function lap-funcs)) (comp-add-func-to-ctxt (comp-limplify-top-level nil)) - (comp-add-func-to-ctxt (comp-limplify-top-level t))) + (when (comp-ctxt-with-late-load comp-ctxt) + (comp-add-func-to-ctxt (comp-limplify-top-level t)))) ;;; SSA pass specific code. @@ -2163,7 +2166,7 @@ display a message." ;;; Compiler entry points. ;;;###autoload -(defun native-compile (function-or-file) +(defun native-compile (function-or-file &optional with-late-load) "Compile FUNCTION-OR-FILE into native code. This is the entry-point for the Emacs Lisp native compiler. FUNCTION-OR-FILE is a function symbol or a path to an Elisp file. @@ -2188,7 +2191,8 @@ Return the compilation unit file name." (output-filename (file-name-sans-extension (file-name-nondirectory expanded-filename)))) - (expand-file-name output-filename output-dir)))))) + (expand-file-name output-filename output-dir))) + :with-late-load with-late-load))) (comp-log "\n \n" 1) (condition-case err (mapc (lambda (pass) commit f2c437761f5b9f0256d9b2e2687e0ab889274c46 Author: Andrea Corallo Date: Tue Mar 17 21:35:11 2020 +0000 * comp.el: Have the compiler generates 'late_top_level_run' diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 0728c4f0a8..3a56876cc0 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1137,10 +1137,10 @@ the annotation emission." (comp-log-func func 2) func) -(cl-defgeneric comp-emit-for-top-level (form) +(cl-defgeneric comp-emit-for-top-level (form for-late-load) "Emit the limple code for top level FORM.") -(cl-defmethod comp-emit-for-top-level ((form byte-to-native-function)) +(cl-defmethod comp-emit-for-top-level ((form byte-to-native-function) _) (let* ((name (byte-to-native-function-name form)) (f (gethash name (comp-ctxt-funcs-h comp-ctxt))) (args (comp-func-args f))) @@ -1159,16 +1159,19 @@ the annotation emission." ;; parameter. (make-comp-mvar :slot 0))))) -(cl-defmethod comp-emit-for-top-level ((form byte-to-native-top-level)) - (let ((form (byte-to-native-top-level-form form))) - (comp-emit (comp-call 'eval - (let ((comp-curr-allocation-class 'd-impure)) - (make-comp-mvar :constant form)) - (make-comp-mvar :constant t))))) +(cl-defmethod comp-emit-for-top-level ((form byte-to-native-top-level) + for-late-load) + (unless for-late-load + (let ((form (byte-to-native-top-level-form form))) + (comp-emit (comp-call 'eval + (let ((comp-curr-allocation-class 'd-impure)) + (make-comp-mvar :constant form)) + (make-comp-mvar :constant t)))))) -(defun comp-limplify-top-level () - "Create a limple function doing the business for top level forms. -This will be called at load-time. +(defun comp-limplify-top-level (for-late-load) + "Create a limple function to modify the global environment at load. +When FOR-LATE-LOAD is non nil the emitted function modifies only +function definition. Synthesize a function called 'top_level_run' that gets one single parameter (the compilation unit it-self). To define native @@ -1178,8 +1181,12 @@ into the C code forwarding the compilation unit." ;; reasons to be execute ever again. Therefore all objects can be ;; just ephemeral. (let* ((comp-curr-allocation-class 'd-ephemeral) - (func (make-comp-func :name 'top-level-run - :c-name "top_level_run" + (func (make-comp-func :name (if for-late-load + 'late-top-level-run + 'top-level-run) + :c-name (if for-late-load + "late_top_level_run" + "top_level_run") :args (make-comp-args :min 1 :max 1) :frame-size 1)) (comp-func func) @@ -1187,10 +1194,13 @@ into the C code forwarding the compilation unit." :curr-block (make--comp-block -1 0 'top-level) :frame (comp-new-frame 1)))) (comp-make-curr-block 'entry (comp-sp)) - (comp-emit-annotation "Top level") + (comp-emit-annotation (if for-late-load + "Late top level" + "Top level")) ;; Assign the compilation unit incoming as parameter to the slot frame 0. (comp-emit `(set-par-to-local ,(comp-slot-n 0) 0)) - (mapc #'comp-emit-for-top-level (comp-ctxt-top-level-forms comp-ctxt)) + (mapc (lambda (x) (comp-emit-for-top-level x for-late-load)) + (comp-ctxt-top-level-forms comp-ctxt)) (comp-emit `(return ,(make-comp-mvar :constant t))) (puthash 0 (comp-func-frame-size func) (comp-func-array-h func)) (comp-limplify-finalize-function func))) @@ -1278,7 +1288,8 @@ into the C code forwarding the compilation unit." "Compute the LIMPLE ir for LAP-FUNCS. Top-level forms for the current context are rendered too." (mapc #'comp-add-func-to-ctxt (mapcar #'comp-limplify-function lap-funcs)) - (comp-add-func-to-ctxt (comp-limplify-top-level))) + (comp-add-func-to-ctxt (comp-limplify-top-level nil)) + (comp-add-func-to-ctxt (comp-limplify-top-level t))) ;;; SSA pass specific code. commit e57d5a71ba765bbd225974b3d61ecd9d80f73220 Merge: 159f61baa9 9dccaf8a5c Author: Andrea Corallo Date: Mon Mar 16 23:08:47 2020 +0000 Merge remote-tracking branch 'savannah/master' into HEAD commit 159f61baa9e374cfd17acf1a45c0d553b57b7ac9 Author: Andrea Corallo Date: Sun Mar 15 21:44:05 2020 +0000 Trigger native compilation when loading bytecode Introduce a first mechanism to trigger compilation when lex elc files are loaded. This is off by default and has to be better tested. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index c00a68307b..0728c4f0a8 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -40,6 +40,11 @@ "Emacs Lisp native compiler." :group 'lisp) +(defcustom comp-deferred-compilation nil + "If t compile asyncronously all lexically bound .elc files being loaded." + :type 'boolean + :group 'comp) + (defcustom comp-speed 2 "Compiler optimization level. From 0 to 3. - 0 no optimizations are performed, compile time is favored. diff --git a/src/comp.c b/src/comp.c index b9ecef07f3..74b74a83b7 100644 --- a/src/comp.c +++ b/src/comp.c @@ -492,7 +492,7 @@ declare_imported_func (Lisp_Object subr_sym, gcc_jit_type *ret_type, /* String containing the function ptr name. */ Lisp_Object f_ptr_name = - CALLN (Ffuncall, intern_c_string (STR (comp-c-func-name)), + CALLN (Ffuncall, intern_c_string ("comp-c-func-name"), subr_sym, make_string ("R", 1)); gcc_jit_type *f_ptr_type = @@ -3359,6 +3359,40 @@ helper_PSEUDOVECTOR_TYPEP_XUNTAG (Lisp_Object a, enum pvec_type code) code); } + +/***********************************/ +/* Deferred compilation mechanism. */ +/***********************************/ + +void +maybe_defer_native_compilation (Lisp_Object function_name, + Lisp_Object definition) +{ + Lisp_Object src = Qnil; + Lisp_Object load_list = Vcurrent_load_list; + + FOR_EACH_TAIL (load_list) + { + src = XCAR (load_list); + if (!CONSP (src)) + break; + } + + if (!comp_deferred_compilation + || noninteractive + || !NILP (Vpurify_flag) + || !COMPILEDP (definition) + || !FIXNUMP (AREF (definition, COMPILED_ARGLIST)) + || !STRINGP (src) + || !suffix_p (src, ".elc")) + return; + + src = concat2 (CALL1I (file-name-sans-extension, src), + build_pure_c_string (".el")); + if (!NILP (Ffile_exists_p (src))) + CALLN (Ffuncall, intern_c_string ("native-compile-async"), src, Qnil); +} + /**************************************/ /* Functions used to load eln files. */ @@ -3552,6 +3586,8 @@ void syms_of_comp (void) { /* Compiler control customizes. */ + DEFVAR_BOOL ("comp-deferred-compilation", comp_deferred_compilation, + doc: /* If t compile asyncronously every .elc file loaded. */); DEFSYM (Qcomp_speed, "comp-speed"); DEFSYM (Qcomp_debug, "comp-debug"); diff --git a/src/comp.h b/src/comp.h index 070ec4d5ca..f3bcd4c09b 100644 --- a/src/comp.h +++ b/src/comp.h @@ -68,5 +68,15 @@ extern void load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u, bool loading_dump); extern void syms_of_comp (void); +extern void maybe_defer_native_compilation (Lisp_Object function_name, + Lisp_Object definition); +#else + +static inline void +maybe_defer_native_compilation (Lisp_Object function_name, + Lisp_Object definition) +{} + #endif + #endif diff --git a/src/data.c b/src/data.c index 8a0546ce09..173b92c5bf 100644 --- a/src/data.c +++ b/src/data.c @@ -814,6 +814,8 @@ The return value is undefined. */) Ffset (symbol, definition); } + maybe_defer_native_compilation (symbol, definition); + if (!NILP (docstring)) Fput (symbol, Qfunction_documentation, docstring); /* We used to return `definition', but now that `defun' and `defmacro' expand diff --git a/src/lisp.h b/src/lisp.h index cd543f5047..9695976487 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -4102,6 +4102,7 @@ LOADHIST_ATTACH (Lisp_Object x) if (initialized) Vcurrent_load_list = Fcons (x, Vcurrent_load_list); } +extern bool suffix_p (Lisp_Object, const char *); extern Lisp_Object save_match_data_load (Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object); extern int openp (Lisp_Object, Lisp_Object, Lisp_Object, diff --git a/src/lread.c b/src/lread.c index 32c83bfae8..2d90bccdc0 100644 --- a/src/lread.c +++ b/src/lread.c @@ -1077,7 +1077,7 @@ effective_load_path (void) } /* Return true if STRING ends with SUFFIX. */ -static bool +bool suffix_p (Lisp_Object string, const char *suffix) { ptrdiff_t suffix_len = strlen (suffix); commit ea8864fb672a7ff2d1da1b91885239f60e16b359 Author: Andrea Corallo Date: Sun Mar 15 21:07:14 2020 +0000 * comp.el: (native-compile-async) do not duplicate queue entries diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 68d3b8b2c7..c00a68307b 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2229,7 +2229,8 @@ of given directories." ((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)) + (dolist (file files) + (add-to-list 'comp-files-queue file t)) (when (zerop (comp-async-runnings)) (comp-run-async-workers)) (message "Compilation started."))) commit 0b28bf0529cc6e6125924cc54ba8de30f3872ab9 Author: Andrea Corallo Date: Sun Mar 15 20:17:15 2020 +0000 * comp.el: Estimate async worker number using system CPU number This only when `comp-async-jobs-number' is 0 (default). diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index f47d3ce470..68d3b8b2c7 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -85,8 +85,9 @@ performed at `comp-speed' > 0." :type 'list :group 'comp) -(defcustom comp-async-jobs-number 2 - "Default number of processes used for async compilation." +(defcustom comp-async-jobs-number 0 + "Default number of processes used for async compilation. +When zero use half of the CPUs or at least one." :type 'fixnum :group 'comp) @@ -2082,13 +2083,25 @@ processes from `comp-async-processes'" (cl-delete-if-not #'process-live-p comp-async-processes)) (length comp-async-processes)) +(let (num-cpus) + (defun comp-effective-async-max-jobs () + "Compute the effective number of async jobs." + (if (zerop comp-async-jobs-number) + (or num-cpus + (setf num-cpus + ;; Half of the CPUs or at least one. + ;; FIXME portable? + (max 1 (/ (string-to-number (shell-command-to-string "nproc")) + 2)))) + comp-async-jobs-number))) + (defun comp-run-async-workers () "Start compiling files from `comp-files-queue' asynchronously. When compilation is finished, run `comp-async-all-done-hook' and display a message." (if (or comp-files-queue (> (comp-async-runnings) 0)) - (unless (>= (comp-async-runnings) comp-async-jobs-number) + (unless (>= (comp-async-runnings) (comp-effective-async-max-jobs)) (cl-loop for source-file = (pop comp-files-queue) while source-file @@ -2119,7 +2132,7 @@ display a message." (accept-process-output process) (comp-run-async-workers))))) (push process comp-async-processes)) - when (>= (comp-async-runnings) comp-async-jobs-number) + when (>= (comp-async-runnings) (comp-effective-async-max-jobs)) do (cl-return))) ;; No files left to compile and all processes finished. (let ((msg "Compilation finished.")) commit 92fdfa4b5a468d9560e21a5a22a83847fd8ca2c7 Author: Andrea Corallo Date: Sun Mar 15 19:37:51 2020 +0000 * comp.el: Make compilation logic to be dynamically controllable Introduce `comp-async-jobs-number' to control async job number, this can be now adjusted dynamically. Also make `native-compile-async' able to dynamically queue new compilations. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 0a6a92573f..f47d3ce470 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -85,6 +85,11 @@ performed at `comp-speed' > 0." :type 'list :group 'comp) +(defcustom comp-async-jobs-number 2 + "Default number of processes used for async compilation." + :type 'fixnum + :group 'comp) + (defcustom comp-async-cu-done-hook nil "This hook is run whenever an asyncronous native compilation finishes compiling a single compilation unit. @@ -2069,51 +2074,61 @@ Prepare every function for final compilation and drive the C back-end." (defvar comp-async-processes () "List of running async compilation processes.") -(defun comp-start-async-worker () +(defun comp-async-runnings () + "Return the number of async compilations currently running. +This function has the side effect of cleaning-up finished +processes from `comp-async-processes'" + (setf comp-async-processes + (cl-delete-if-not #'process-live-p comp-async-processes)) + (length comp-async-processes)) + +(defun comp-run-async-workers () "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-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))))) + (if (or comp-files-queue + (> (comp-async-runnings) 0)) + (unless (>= (comp-async-runnings) comp-async-jobs-number) + (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-run-async-workers))))) + (push process comp-async-processes)) + when (>= (comp-async-runnings) comp-async-jobs-number) + do (cl-return))) + ;; No files left to compile and all processes finished. + (let ((msg "Compilation finished.")) + (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)))) ;;; Compiler entry points. @@ -2183,12 +2198,12 @@ Always generate elc files too and handle native compiler expected errors." (rename-file tempfile target-file t)))))) ;;;###autoload -(cl-defun native-compile-async (paths &optional (jobs 1) recursively) +(defun native-compile-async (paths 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." +`comp-async-jobs-number' specifies the number of (commands) to +run simultaneously. If RECURSIVELY, recurse into subdirectories +of given directories." (unless (listp paths) (setf paths (list paths))) (let (files) @@ -2202,8 +2217,8 @@ subdirectories of given directories." (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)) + (when (zerop (comp-async-runnings)) + (comp-run-async-workers)) (message "Compilation started."))) (provide 'comp) commit a8c20f67be52da6c5fb03aa1beded2219783fca6 Merge: 62bc0c2d7a b39b564725 Author: Andrea Corallo Date: Sun Mar 15 10:31:03 2020 +0000 Merge remote-tracking branch 'savannah/master' into HEAD commit 62bc0c2d7a24e3635b3611a95deb5013971759e2 Author: Andrea Corallo Date: Sun Mar 15 10:27:38 2020 +0000 * .gitlab-ci.yml: Always run test-filenotify-gio test-filenotify-gio is run always to keep stock bootstrap tested. diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 5069ad5fe0..fa613bb412 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -51,15 +51,17 @@ stages: test-filenotify-gio: stage: test # This tests file monitor libraries gfilemonitor and gio. - only: - changes: - - .gitlab-ci.yml - - lisp/autorevert.el - - lisp/filenotify.el - - lisp/net/tramp-sh.el - - src/gfilenotify.c - - test/lisp/autorevert-tests.el - - test/lisp/filenotify-tests.el + + ## Commented to keep stock bootstrap tested. + # only: + # changes: + # - .gitlab-ci.yml + # - lisp/autorevert.el + # - lisp/filenotify.el + # - lisp/net/tramp-sh.el + # - src/gfilenotify.c + # - test/lisp/autorevert-tests.el + # - test/lisp/filenotify-tests.el script: - DEBIAN_FRONTEND=noninteractive apt install --no-install-recommends -y -qq -o=Dpkg::Use-Pty=0 libglib2.0-dev libglib2.0-bin libglib2.0-0 - ./autogen.sh autoconf commit 7359f9e36366221a03e3516375ec415d6df4df65 Author: Andrea Corallo Date: Sun Mar 15 10:26:31 2020 +0000 * comp.el: Fix missing rx require diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 2ce530ee59..0a6a92573f 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -29,10 +29,11 @@ ;;; Code: (require 'bytecomp) -(require 'gv) -(require 'cl-lib) (require 'cl-extra) +(require 'cl-lib) (require 'cl-macs) +(require 'gv) +(require 'rx) (require 'subr-x) (defgroup comp nil commit 46a4ca4774e27f76c93277db187df31aa6e1cf2e Author: Adam Porter Date: Sun Mar 15 10:19:22 2020 +0000 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. diff --git a/configure.ac b/configure.ac index 0b2f5b69d6..393a53d763 100644 --- a/configure.ac +++ b/configure.ac @@ -463,7 +463,7 @@ OPTION_DEFAULT_ON([gnutls],[don't use -lgnutls for SSL/TLS support]) 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 0779373667..2ce530ee59 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -356,34 +356,44 @@ Assume allocaiton class 'd-default as default." (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 @@ Prepare every function for final compilation and drive the C back-end." ;; 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))))) + ;;; 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 \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 @@ Always generate elc files too and handle native compiler expected errors." (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."))) commit 7438001385889f6527ab5832c867392f3074c778 Merge: dab8dd836c 1de9e0f368 Author: Andrea Corallo Date: Sat Mar 14 15:14:12 2020 +0000 Merge remote-tracking branch 'savannah/master' into HEAD commit dab8dd836cb7c714cebae155f41e21fd824acaea Author: Andrea Corallo Date: Sat Mar 14 10:57:34 2020 +0000 Fix make bootstrap for native compilation Add Makefile target native-compile-clean removing all eln output folders. This is also triggered by make bootstrap to perform a clean bootstrap. Also revert some modification of the build system against master not effective anymore with the new directory layout. diff --git a/lisp/Makefile.in b/lisp/Makefile.in index fdd39d5fd5..8ba619656d 100644 --- a/lisp/Makefile.in +++ b/lisp/Makefile.in @@ -356,6 +356,13 @@ compile-main: gen-lisp compile-clean $(MAKE) compile-targets TARGETS="$$chunk"; \ done +.PHONY: native-compile-clean +native-compile-clean: +# Erase all eln output compilation folders. +ifeq ($(HAVE_NATIVE_COMP),yes) + find $(lisp) -regex ".*/eln-.*-[0-9a-z]+\\'" -type d | xargs rm -rf +endif + .PHONY: compile-clean # Erase left-over .elc files that do not have a corresponding .el file. compile-clean: @@ -366,10 +373,6 @@ compile-clean: echo rm "$${el}c"; \ rm "$${el}c"; \ fi; \ - if test -f "$$el" || test ! -f "$${el}n"; then :; else \ - echo rm "$${el}n"; \ - rm "$${el}n"; \ - fi; \ done .PHONY: gen-lisp leim semantic @@ -396,7 +399,7 @@ compile: $(LOADDEFS) autoloads compile-first # Compile all Lisp files. This is like 'compile' but compiles files # unconditionally. Some files don't actually get compiled because they # set the local variable no-byte-compile. -compile-always: +compile-always: native-compile-clean find $(lisp) -name '*.elc' $(FIND_DELETE) $(MAKE) compile @@ -486,8 +489,8 @@ $(CAL_DIR)/hol-loaddefs.el: $(CAL_SRC) $(CAL_DIR)/diary-loaddefs.el .PHONY: bootstrap-clean distclean maintainer-clean extraclean -bootstrap-clean: - find $(lisp) -regex '.*\.elc\|.*\.eln' $(FIND_DELETE) +bootstrap-clean: native-compile-clean + find $(lisp) -name '*.elc' $(FIND_DELETE) rm -f $(AUTOGENEL) distclean: diff --git a/src/Makefile.in b/src/Makefile.in index 52d8ddd4e5..8d7fdb8a60 100644 --- a/src/Makefile.in +++ b/src/Makefile.in @@ -327,7 +327,7 @@ GMP_LIB = @GMP_LIB@ GMP_OBJ = @GMP_OBJ@ LIBGCCJIT = @LIBGCCJIT_LIB@ -## dynlib.o comp.o if native compiler is enabled, else empty +## dynlib.o comp.o if native compiler is enabled, otherwise empty. COMP_OBJ = @COMP_OBJ@ RUN_TEMACS = ./temacs commit 144e8f64b69e01a6c870574d04c92368f0056dd0 Author: Andrea Corallo Date: Fri Mar 13 22:16:21 2020 +0000 Prefix native compilation folders with "eln-" diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 64eb46cc38..0779373667 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2126,6 +2126,7 @@ Return the compilation unit file name." (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 diff --git a/src/comp.c b/src/comp.c index 8176ba259e..b9ecef07f3 100644 --- a/src/comp.c +++ b/src/comp.c @@ -266,11 +266,12 @@ hash_native_abi (void) /* If 10 characters are usually sufficient for git I guess 16 are fine for us here. */ Vcomp_native_path_postfix = - concat3 (Vsystem_configuration, - make_string ("-", 1), - Fsubstring_no_properties (Vcomp_abi_hash, - make_fixnum (0), - make_fixnum (16))); + concat3 (make_string ("eln-", 4), + Vsystem_configuration, + concat2 (make_string ("-", 1), + Fsubstring_no_properties (Vcomp_abi_hash, + make_fixnum (0), + make_fixnum (16)))); } static void commit ab8fed0a96a55107895e6105e7b0e4b6735156d7 Author: Andrea Corallo Date: Thu Mar 12 22:36:39 2020 +0000 * Do not produce .eln files when a byte compilation error happen Have the byte compiler signal an error when compilation fails to stop native compilation too. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 808a705a5c..64eb46cc38 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2118,6 +2118,9 @@ Return the compilation unit file name." (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) commit d0a504f5c41be7136cec7fbab9829f80d6583fcf Merge: 5f8b630823 3db5a51384 Author: Andrea Corallo Date: Thu Mar 12 22:41:57 2020 +0000 Merge remote-tracking branch 'savannah/master' into HEAD commit 5f8b63082331de5573e0c401bf9a3a38394cbdf7 Merge: 566f0f1b63 a98c8f5a09 Author: Andrea Corallo Date: Tue Mar 10 10:47:59 2020 +0000 Merge remote-tracking branch 'savannah/master' into HEAD commit 566f0f1b639c7cba5b7d6763fb13aa42a5cc4535 Author: AndreaCorallo Date: Mon Mar 9 22:00:37 2020 +0000 * Improve load_comp_unit Fix uninitialized ephemeral data relocation for the case when a dumped compilation unit is manually reloaded. Guard also data_ephemeral_vec against compiler optimizations. diff --git a/src/comp.c b/src/comp.c index 4940ae52b3..8176ba259e 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3388,6 +3388,8 @@ load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u, bool loading_dump) if (!saved_cu) xsignal1 (Qnative_lisp_file_inconsistent, comp_u->file); bool reloading_cu = *saved_cu ? true : false; + Lisp_Object *data_eph_relocs = + dynlib_sym (handle, DATA_RELOC_EPHEMERAL_SYM); /* While resurrecting from an image dump loading more than once the same compilation unit does not make any sense. */ @@ -3419,19 +3421,7 @@ load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u, bool loading_dump) EMACS_INT ***pure_reloc = dynlib_sym (handle, PURE_RELOC_SYM); Lisp_Object *data_relocs = dynlib_sym (handle, DATA_RELOC_SYM); Lisp_Object *data_imp_relocs = dynlib_sym (handle, DATA_RELOC_IMPURE_SYM); - Lisp_Object *data_eph_relocs = - dynlib_sym (handle, DATA_RELOC_EPHEMERAL_SYM); void **freloc_link_table = dynlib_sym (handle, FUNC_LINK_TABLE_SYM); - Lisp_Object volatile data_ephemeral_vec; - - /* Note: data_ephemeral_vec is not GC protected except than by - this function frame. After this functions will be - deactivated GC will be free to collect it, but it MUST - survive till 'top_level_run' has finished his job. We store - into the ephemeral allocation class only objects that we know - are necessary exclusively during the first load. Once these - are collected we don't have to maintain them in the heap - forever. */ if (!(current_thread_reloc && pure_reloc @@ -3457,12 +3447,6 @@ load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u, bool loading_dump) comp_u->data_vec = load_static_obj (comp_u, TEXT_DATA_RELOC_SYM); comp_u->data_impure_vec = load_static_obj (comp_u, TEXT_DATA_RELOC_IMPURE_SYM); - data_ephemeral_vec = - load_static_obj (comp_u, TEXT_DATA_RELOC_EPHEMERAL_SYM); - - EMACS_INT d_vec_len = XFIXNUM (Flength (data_ephemeral_vec)); - for (EMACS_INT i = 0; i < d_vec_len; i++) - data_eph_relocs[i] = AREF (data_ephemeral_vec, i); if (!NILP (Vpurify_flag)) /* Non impure can be copied into pure space. */ @@ -3479,9 +3463,30 @@ load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u, bool loading_dump) } if (!loading_dump) - /* Executing this will perform all the expected environment - modifications. */ - top_level_run (comp_u_lisp_obj); + { + /* Note: data_ephemeral_vec is not GC protected except than by + this function frame. After this functions will be + deactivated GC will be free to collect it, but it MUST + survive till 'top_level_run' has finished his job. We store + into the ephemeral allocation class only objects that we know + are necessary exclusively during the first load. Once these + are collected we don't have to maintain them in the heap + forever. */ + + Lisp_Object volatile data_ephemeral_vec = + load_static_obj (comp_u, TEXT_DATA_RELOC_EPHEMERAL_SYM); + + EMACS_INT d_vec_len = XFIXNUM (Flength (data_ephemeral_vec)); + for (EMACS_INT i = 0; i < d_vec_len; i++) + data_eph_relocs[i] = AREF (data_ephemeral_vec, i); + + /* Executing this will perform all the expected environment + modifications. */ + top_level_run (comp_u_lisp_obj); + /* Make sure data_ephemeral_vec still exists after top_level_run has run. + Guard against sibling call optimization (or any other). */ + data_ephemeral_vec = data_ephemeral_vec; + } return; } commit e23856167be46d7817ba02238e25dce37183bd2a Author: AndreaCorallo Date: Mon Mar 9 16:51:15 2020 +0000 * Fix store_function_docstring for for native functions Do not Nil native_doc fields. This will be naturally dumped by pdumper. This was affecting dumped functions. diff --git a/src/doc.c b/src/doc.c index 192e201109..1b6aa01ef0 100644 --- a/src/doc.c +++ b/src/doc.c @@ -510,12 +510,8 @@ store_function_docstring (Lisp_Object obj, EMACS_INT offset) XSETCAR (tem, make_fixnum (offset)); } } - else if (SUBR_NATIVE_COMPILEDP (fun)) - { - XSUBR (fun)->native_doc = Qnil; - } /* Lisp_Subrs have a slot for it. */ - else if (SUBRP (fun)) + else if (SUBRP (fun) && !SUBR_NATIVE_COMPILEDP (fun)) { XSUBR (fun)->doc = offset; } commit 2cf4b81009eeedd1b441af093c0ca147d0d9bbb9 Author: Andrea Corallo Date: Mon Mar 9 10:45:51 2020 +0000 * Fix GC mark for native compiled functions native_intspec and native_doc fields has to be reached by the subr cause are not anymore in the CU. diff --git a/src/alloc.c b/src/alloc.c index 9a01edca3f..ac17307713 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -6683,9 +6683,9 @@ mark_object (Lisp_Object arg) { set_vector_marked (ptr); struct Lisp_Subr *subr = XSUBR (obj); - obj = subr->native_comp_u[0]; - eassert (obj); - goto loop; + mark_object (subr->native_intspec); + mark_object (subr->native_doc); + mark_object (subr->native_comp_u[0]); } break; commit f21e1dfc9f9addf66e6913cd30fbd7f922510ede Author: AndreaCorallo Date: Mon Mar 9 17:35:07 2020 +0000 * Set relocation class as ephemeral in `comp-limplify-top-level' diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index f16aa59dc5..808a705a5c 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1154,8 +1154,8 @@ functions 'top_level_run' will call back `comp--register-subr' into the C code forwarding the compilation unit." ;; Once an .eln is loaded and Emacs is dumped 'top_level_run' has no ;; reasons to be execute ever again. Therefore all objects can be - ;; just impure. - (let* ((comp-curr-allocation-class 'd-impure) + ;; just ephemeral. + (let* ((comp-curr-allocation-class 'd-ephemeral) (func (make-comp-func :name 'top-level-run :c-name "top_level_run" :args (make-comp-args :min 1 :max 1) commit 87ee6ff4eb6df369965f37fba073e3ef1bb5d0bd Merge: 9838ee7ed8 a461baae79 Author: Andrea Corallo Date: Mon Mar 9 07:49:33 2020 +0000 Merge remote-tracking branch 'savannah/master' into HEAD commit 9838ee7ed870844470703b2648f8b59c0575bd46 Author: Andrea Corallo Date: Mon Mar 9 07:47:57 2020 +0000 * Fix regexp instroduced by f055f52321 diff --git a/lisp/emacs-lisp/find-func.el b/lisp/emacs-lisp/find-func.el index 21c10029ac..fa87b25569 100644 --- a/lisp/emacs-lisp/find-func.el +++ b/lisp/emacs-lisp/find-func.el @@ -187,7 +187,7 @@ LIBRARY should be a string (the name of the library)." (cond ((string-match "\\.el\\(c\\(\\..*\\)?\\)\\'" library) (setq library (replace-match "" t t library))) - ((string-match "\\.eln$" library) + ((string-match "\\.eln\\'" library) ;; From help-fns.el. (setq library (expand-file-name (concat (file-name-base library) ".el") commit dc7ccfaf0fe7580afb59e0ebe5b44123f5c4c586 Author: Andrea Corallo Date: Sun Mar 8 22:33:54 2020 +0000 * Fix typo into pdumper integration diff --git a/src/pdumper.c b/src/pdumper.c index 71551d7c70..4ecdea1453 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -5320,7 +5320,7 @@ dump_do_dump_relocation (const uintptr_t dump_base, error ("missing label name"); void *func = dynlib_sym (comp_u->handle, SSDATA (c_name)); if (!func) - error ("can't function in compilation unit"); + error ("can't find function in compilation unit"); subr->function.a0 = func; break; } commit 4c8a84002f4c1a2d30f96fa451dd221605ab84e3 Author: Andrea Corallo Date: Sun Mar 8 21:40:51 2020 +0000 * New native-comp CI setup - Disable 'test-all' till is known to be broken in this branch. - Run 'test-native-bootstrap' always (not only when scheduled). - Set 'test-native-bootstrap' timeout to 3 hours. diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index d081bb7c47..5069ad5fe0 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -37,15 +37,16 @@ before_script: stages: - test -test-all: - # This tests also file monitor libraries inotify and inotifywatch. - stage: test - script: - - DEBIAN_FRONTEND=noninteractive apt install --no-install-recommends -y -qq -o=Dpkg::Use-Pty=0 inotify-tools - - ./autogen.sh autoconf - - ./configure --without-makeinfo - - make bootstrap - - make check-expensive +# FIXME: Commented for this branch till is known to be broken. +# test-all: +# # This tests also file monitor libraries inotify and inotifywatch. +# stage: test +# script: +# - DEBIAN_FRONTEND=noninteractive apt install --no-install-recommends -y -qq -o=Dpkg::Use-Pty=0 inotify-tools +# - ./autogen.sh autoconf +# - ./configure --without-makeinfo +# - make bootstrap +# - make check-expensive test-filenotify-gio: stage: test @@ -70,11 +71,12 @@ test-native-bootstrap: # Test native bootstrap # Run for now only speed 0 to limit memory usage and compilation time. stage: test - only: - - schedules + # Uncomment the following to run it only when sceduled. + # only: + # - schedules script: - DEBIAN_FRONTEND=noninteractive apt install --no-install-recommends -y -qq -o=Dpkg::Use-Pty=0 libgccjit-6-dev - ./autogen.sh autoconf - ./configure --without-makeinfo --with-nativecomp - make bootstrap BYTE_COMPILE_EXTRA_FLAGS='--eval "(setq comp-speed 0)"' -j2 - timeout: 10 hours + timeout: 3 hours commit f055f523216d6aa5fe2b59984e0aed81ca80b66e Author: Andrea Corallo Date: Sun Mar 8 21:30:28 2020 +0000 * Fix two find function functions for native compilation `find-function-library' and `find-library-name' gets fixed for new eln compilation directory layout. diff --git a/lisp/emacs-lisp/find-func.el b/lisp/emacs-lisp/find-func.el index 86b5e5456f..21c10029ac 100644 --- a/lisp/emacs-lisp/find-func.el +++ b/lisp/emacs-lisp/find-func.el @@ -184,8 +184,15 @@ See the functions `find-function' and `find-variable'." LIBRARY should be a string (the name of the library)." ;; If the library is byte-compiled, try to find a source library by ;; the same name. - (when (string-match "\\.el\\([cn]\\(\\..*\\)?\\)\\'" library) + (cond + ((string-match "\\.el\\(c\\(\\..*\\)?\\)\\'" library) (setq library (replace-match "" t t library))) + ((string-match "\\.eln$" library) + ;; From help-fns.el. + (setq library (expand-file-name (concat (file-name-base library) + ".el") + (concat (file-name-directory library) + ".."))))) (or (locate-file library (or find-function-source-path load-path) @@ -439,7 +446,7 @@ message about the whole chain of aliases." (cons function (cond ((autoloadp def) (nth 1 def)) - ((subrp def) + ((and (subrp def) (not (subr-native-elisp-p def))) (if lisp-only (error "%s is a built-in function" function)) (help-C-file-name def 'subr)) commit 6c3efad161dcccf28bf6db1b0b714b012059e719 Author: Andrea Corallo Date: Sun Mar 8 12:34:43 2020 +0000 * test-native-bootstrap CI test configured for speed 0 Run for now only speed 0 to limit memory usage and compilation time. diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 51968a158f..d081bb7c47 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -68,6 +68,7 @@ test-filenotify-gio: test-native-bootstrap: # Test native bootstrap + # Run for now only speed 0 to limit memory usage and compilation time. stage: test only: - schedules @@ -75,5 +76,5 @@ test-native-bootstrap: - DEBIAN_FRONTEND=noninteractive apt install --no-install-recommends -y -qq -o=Dpkg::Use-Pty=0 libgccjit-6-dev - ./autogen.sh autoconf - ./configure --without-makeinfo --with-nativecomp - - make bootstrap -j2 + - make bootstrap BYTE_COMPILE_EXTRA_FLAGS='--eval "(setq comp-speed 0)"' -j2 timeout: 10 hours commit cd9c1e48890f935731a6bfb3d5106fa42df08258 Author: Andrea Corallo Date: Sat Mar 7 19:12:36 2020 +0000 * Raise timeout for test-native-bootstrap CI test and build with -j2 diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 7b31810fd3..51968a158f 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -75,4 +75,5 @@ test-native-bootstrap: - DEBIAN_FRONTEND=noninteractive apt install --no-install-recommends -y -qq -o=Dpkg::Use-Pty=0 libgccjit-6-dev - ./autogen.sh autoconf - ./configure --without-makeinfo --with-nativecomp - - make bootstrap + - make bootstrap -j2 + timeout: 10 hours commit e4b5bd990b5a4b658f0e38451f0a910d4515a968 Author: Andrea Corallo Date: Fri Mar 6 21:16:43 2020 +0000 * Add test-native-bootstrap as CI test diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 9a62137c16..7b31810fd3 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -65,3 +65,14 @@ test-filenotify-gio: - ./configure --without-makeinfo --with-file-notification=gfile - make bootstrap - make -C test autorevert-tests filenotify-tests + +test-native-bootstrap: + # Test native bootstrap + stage: test + only: + - schedules + script: + - DEBIAN_FRONTEND=noninteractive apt install --no-install-recommends -y -qq -o=Dpkg::Use-Pty=0 libgccjit-6-dev + - ./autogen.sh autoconf + - ./configure --without-makeinfo --with-nativecomp + - make bootstrap commit dc89f3a0df1013c7c5fcb3cff6da27fa0263f007 Author: Andrea Corallo Date: Wed Mar 4 21:52:38 2020 +0000 * Fix build for stock configuration Vcomp_native_path_postfix is declared only in native configuration. diff --git a/src/lread.c b/src/lread.c index acd2fea688..32c83bfae8 100644 --- a/src/lread.c +++ b/src/lread.c @@ -1058,9 +1058,9 @@ This uses the variables `load-suffixes' and `load-file-rep-suffixes'. */) static Lisp_Object effective_load_path (void) { - if (!NATIVE_COMP_FLAG) - return Vload_path; - +#ifndef HAVE_NATIVE_COMP + return Vload_path; +#else Lisp_Object lp = Vload_path; Lisp_Object new_lp = Qnil; FOR_EACH_TAIL (lp) @@ -1073,6 +1073,7 @@ effective_load_path (void) new_lp = Fcons (el, new_lp); } return Fnreverse (new_lp); +#endif } /* Return true if STRING ends with SUFFIX. */ commit 6487d4ac5da92aab4d54b5702bba24a5a1ce8432 Merge: 1f3ba658fc cf45e8022e Author: Andrea Corallo Date: Wed Mar 4 11:07:53 2020 +0000 Merge remote-tracking branch 'savannah/master' into HEAD commit 1f3ba658fccdb0b35bdbbdfeb8591dba72ee983f Author: AndreaCorallo Date: Tue Mar 3 23:06:46 2020 +0000 * Do not crash if the output directory is created in the meanwhile diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 342faa2879..f16aa59dc5 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2013,7 +2013,9 @@ Prepare every function for final compilation and drive the C back-end." (let ((dir (file-name-directory name))) (comp-finalize-relocs) (unless (file-exists-p dir) - (make-directory dir)) + ;; In case it's created in the meanwhile. + (ignore-error 'file-already-exists + (make-directory dir))) (unless comp-dry-run (comp--compile-ctxt-to-file name)))) commit 43b6f05dfb46637a414520b27430fbe3b0f005fa Author: AndreaCorallo Date: Tue Mar 3 22:23:41 2020 +0000 Hash eln ABI once and add it to the output compilation path diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index a9db8c6ff0..342faa2879 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2125,7 +2125,7 @@ Return the compilation unit file name." (file-name-as-directory (concat (file-name-directory exp-file) - system-configuration)) + comp-native-path-postfix)) (file-name-sans-extension (file-name-nondirectory exp-file)))))))) (comp-log "\n \n" 1) diff --git a/src/comp.c b/src/comp.c index 425784b981..4940ae52b3 100644 --- a/src/comp.c +++ b/src/comp.c @@ -250,8 +250,8 @@ format_string (const char *format, ...) /* Produce a key hashing Vcomp_subr_list. */ -static Lisp_Object -hash_subr_list (void) +void +hash_native_abi (void) { Lisp_Object string = Fmapconcat (intern_c_string ("subr-name"), Vcomp_subr_list, build_string (" ")); @@ -260,7 +260,17 @@ hash_subr_list (void) sha512_buffer (SSDATA (string), SCHARS (string), SSDATA (digest)); hexbuf_digest (SSDATA (digest), SDATA (digest), SHA512_DIGEST_SIZE); - return digest; + /* Check runs once. */ + eassert (Vcomp_abi_hash); + Vcomp_abi_hash = digest; + /* If 10 characters are usually sufficient for git I guess 16 are + fine for us here. */ + Vcomp_native_path_postfix = + concat3 (Vsystem_configuration, + make_string ("-", 1), + Fsubstring_no_properties (Vcomp_abi_hash, + make_fixnum (0), + make_fixnum (16))); } static void @@ -1976,8 +1986,9 @@ emit_ctxt_code (void) fields[n_frelocs++] = xmint_pointer (XCDR (el)); } - /* Compute and store function link table hash. */ - emit_static_object (LINK_TABLE_HASH_SYM, hash_subr_list ()); + /* Sign the .eln for the exposed ABI it expects at load. */ + eassert (!NILP (Vcomp_abi_hash)); + emit_static_object (LINK_TABLE_HASH_SYM, Vcomp_abi_hash); Lisp_Object subr_l = Vcomp_subr_list; FOR_EACH_TAIL (subr_l) @@ -3430,7 +3441,7 @@ load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u, bool loading_dump) && freloc_link_table && top_level_run) || NILP (Fstring_equal (load_static_obj (comp_u, LINK_TABLE_HASH_SYM), - hash_subr_list ()))) + Vcomp_abi_hash))) xsignal1 (Qnative_lisp_file_inconsistent, comp_u->file); *current_thread_reloc = ¤t_thread; @@ -3657,6 +3668,12 @@ syms_of_comp (void) doc: /* Hash table symbol-function -> function-c-name. For internal use during */); Vcomp_sym_subr_c_name_h = CALLN (Fmake_hash_table); + DEFVAR_LISP ("comp-abi-hash", Vcomp_abi_hash, + doc: /* String signing the ABI exposed to .eln files. */); + Vcomp_abi_hash = Qnil; + DEFVAR_LISP ("comp-native-path-postfix", Vcomp_native_path_postfix, + doc: /* Postifix to be added to the .eln compilation path. */); + Vcomp_native_path_postfix = Qnil; } #endif /* HAVE_NATIVE_COMP */ diff --git a/src/comp.h b/src/comp.h index 3aff440ecb..070ec4d5ca 100644 --- a/src/comp.h +++ b/src/comp.h @@ -61,8 +61,12 @@ XNATIVE_COMP_UNIT (Lisp_Object a) } /* Defined in comp.c. */ + +extern void hash_native_abi (void); + extern void load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u, bool loading_dump); extern void syms_of_comp (void); + #endif #endif diff --git a/src/emacs.c b/src/emacs.c index da08aeb902..b16ffa4295 100644 --- a/src/emacs.c +++ b/src/emacs.c @@ -1949,6 +1949,11 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem keys_of_keyboard (); keys_of_keymap (); keys_of_window (); + +#ifdef HAVE_NATIVE_COMP + /* Must be after the last defsubr has run. */ + hash_native_abi (); +#endif } else { diff --git a/src/lread.c b/src/lread.c index 6d33bd3e49..acd2fea688 100644 --- a/src/lread.c +++ b/src/lread.c @@ -1068,7 +1068,7 @@ effective_load_path (void) Lisp_Object el = XCAR (lp); new_lp = Fcons (concat2 (Ffile_name_as_directory (el), - Vsystem_configuration), + Vcomp_native_path_postfix), new_lp); new_lp = Fcons (el, new_lp); } @@ -4427,6 +4427,7 @@ defsubr (union Aligned_Lisp_Subr *aname) XSETSUBR (tem, sname); set_symbol_function (sym, tem); #ifdef HAVE_NATIVE_COMP + eassert (NILP (Vcomp_abi_hash)); Vcomp_subr_list = Fpurecopy (Fcons (tem, Vcomp_subr_list)); #endif } commit f77f6ca77054ca6122df2742345710b7493ad293 Author: AndreaCorallo Date: Tue Mar 3 22:06:08 2020 +0000 Fix org for eln new compilation folder layout diff --git a/lisp/org/org.el b/lisp/org/org.el index f1a7f61a9a..a9303e880b 100644 --- a/lisp/org/org.el +++ b/lisp/org/org.el @@ -78,8 +78,10 @@ (or (eq this-command 'eval-buffer) (condition-case nil - (load (concat (file-name-directory load-file-name) - "org-loaddefs.el") + (load (expand-file-name "org-loaddefs.el" + (if (string-match "[.]eln$" load-file-name) + (concat (file-name-directory load-file-name) "..") + (file-name-directory load-file-name))) nil t t t) (error (message "WARNING: No org-loaddefs.el file could be found from where org.el is loaded.") commit 286e21c4e86e19bac60f871120df6b51893c5849 Author: AndreaCorallo Date: Tue Mar 3 21:01:37 2020 +0000 Rework `find-lisp-object-file-name' Rework it for eln new compilation folder layout. diff --git a/lisp/help-fns.el b/lisp/help-fns.el index 2b7534bc78..e629a40862 100644 --- a/lisp/help-fns.el +++ b/lisp/help-fns.el @@ -325,12 +325,19 @@ found via `load-path'. The return value can also be `C-source', which means that OBJECT is a function or variable defined in C. If no suitable file is found, return nil." (let* ((autoloaded (autoloadp type)) - (file-name (or (and autoloaded (nth 1 type)) + (true-name (or (and autoloaded (nth 1 type)) (symbol-file ;; FIXME: Why do we have this weird "If TYPE is the ;; value returned by `symbol-function' for a function ;; symbol" exception? - object (or (if (symbolp type) type) 'defun))))) + object (or (if (symbolp type) type) 'defun)))) + (file-name (if (and true-name + (string-match "[.]eln\\'" true-name)) + (expand-file-name (concat (file-name-base true-name) + ".el") + (concat (file-name-directory true-name) + "..")) + true-name))) (cond (autoloaded ;; An autoloaded function: Locate the file since `symbol-function' @@ -377,7 +384,7 @@ suitable file is found, return nil." ;; This applies to config files like ~/.emacs, ;; which people sometimes compile. ((let (fn) - (and (string-match "\\`\\..*\\.el[cn]\\'" + (and (string-match "\\`\\..*\\.elc\\'" (file-name-nondirectory file-name)) (string-equal (file-name-directory file-name) (file-name-as-directory (expand-file-name "~"))) @@ -386,9 +393,9 @@ suitable file is found, return nil." ;; When the Elisp source file can be found in the install ;; directory, return the name of that file. ((let ((lib-name - (if (string-match "[.]el[cn]\\'" file-name) + (if (string-match "[.]elc\\'" file-name) (substring-no-properties file-name 0 -1) - file-name))) + file-name))) (or (and (file-readable-p lib-name) lib-name) ;; The library might be compressed. (and (file-readable-p (concat lib-name ".gz")) lib-name)))) @@ -399,7 +406,7 @@ suitable file is found, return nil." ;; name, convert that back to a file name and see if we ;; get the original one. If so, they are equivalent. (if (equal file-name (locate-file lib-name load-path '(""))) - (if (string-match "[.]el[cn]\\'" lib-name) + (if (string-match "[.]elc\\'" lib-name) (substring-no-properties lib-name 0 -1) lib-name) file-name)) commit bf4f620b2f97d218c4d96ff25fa246a4fe32d744 Author: AndreaCorallo Date: Sun Mar 1 21:10:49 2020 +0000 * ; Clean-up out of date comment diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index c3e797b9b1..a9db8c6ff0 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1967,10 +1967,6 @@ These are substituted with a normal 'set' op." (comp-log-func comp-func 3)))) (comp-ctxt-funcs-h comp-ctxt)))) -;; NOTE: After TCO runs edges, phis etc are not updated. In case some -;; other pass that make use of them after here is added `comp-ssa' -;; should be re-run. - ;;; Final pass specific code. commit ce9e3a4ce75acc5450aa39eb4baf601c26aec3fe Author: AndreaCorallo Date: Sat Feb 29 08:36:27 2020 +0000 Introduce 'effective_load_path' diff --git a/src/lread.c b/src/lread.c index 8b6db92cca..6d33bd3e49 100644 --- a/src/lread.c +++ b/src/lread.c @@ -1055,6 +1055,26 @@ This uses the variables `load-suffixes' and `load-file-rep-suffixes'. */) return Fnreverse (lst); } +static Lisp_Object +effective_load_path (void) +{ + if (!NATIVE_COMP_FLAG) + return Vload_path; + + Lisp_Object lp = Vload_path; + Lisp_Object new_lp = Qnil; + FOR_EACH_TAIL (lp) + { + Lisp_Object el = XCAR (lp); + new_lp = + Fcons (concat2 (Ffile_name_as_directory (el), + Vsystem_configuration), + new_lp); + new_lp = Fcons (el, new_lp); + } + return Fnreverse (new_lp); +} + /* Return true if STRING ends with SUFFIX. */ static bool suffix_p (Lisp_Object string, const char *suffix) @@ -1199,7 +1219,9 @@ Return t if the file exists and loads successfully. */) suffixes = CALLN (Fappend, suffixes, Vload_file_rep_suffixes); } - fd = openp (Vload_path, file, suffixes, &found, Qnil, load_prefer_newer); + fd = + openp (effective_load_path (), file, suffixes, &found, Qnil, + load_prefer_newer); } if (fd == -1) commit d0066e30615f135d9eebd48b98dddfcb7cf84ed0 Author: AndreaCorallo Date: Sat Feb 29 08:36:06 2020 +0000 * Keep comp-subr-list into pure space Sad pure space is not effective nowdays but anyway... should go there. diff --git a/src/lread.c b/src/lread.c index 005528782d..8b6db92cca 100644 --- a/src/lread.c +++ b/src/lread.c @@ -4405,7 +4405,7 @@ defsubr (union Aligned_Lisp_Subr *aname) XSETSUBR (tem, sname); set_symbol_function (sym, tem); #ifdef HAVE_NATIVE_COMP - Vcomp_subr_list = Fcons (tem, Vcomp_subr_list); + Vcomp_subr_list = Fpurecopy (Fcons (tem, Vcomp_subr_list)); #endif } commit 8788fab9e1adf8a4f212a850ebae6845878dbad7 Author: AndreaCorallo Date: Wed Feb 26 21:36:48 2020 +0000 ; Nit fix in comment diff --git a/src/comp.c b/src/comp.c index 9dcd5547de..425784b981 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3275,7 +3275,7 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, GCC_JIT_OUTPUT_KIND_DYNAMIC_LIBRARY, SSDATA (tmp_file)); - /* Remove the old eln instead of copying the new one into ti to get + /* Remove the old eln instead of copying the new one into it to get a new inode and prevent crashes in case the old one is currently loaded. */ if (!NILP (Ffile_exists_p (out_file))) commit 2dae7e1b697fef389e8e193d60ef799e2b3b09b4 Author: AndreaCorallo Date: Thu Feb 6 20:23:14 2020 +0000 Add system-configuration in the compilation output path diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index e14f350c2e..c3e797b9b1 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2014,9 +2014,12 @@ Update all insn accordingly." (defun comp-compile-ctxt-to-file (name) "Compile as native code the current context naming it NAME. Prepare every function for final compilation and drive the C back-end." - (comp-finalize-relocs) - (unless comp-dry-run - (comp--compile-ctxt-to-file name))) + (let ((dir (file-name-directory name))) + (comp-finalize-relocs) + (unless (file-exists-p dir) + (make-directory dir)) + (unless comp-dry-run + (comp--compile-ctxt-to-file name)))) (defun comp-final (_) "Final pass driving the C back-end for code emission." @@ -2118,9 +2121,17 @@ Return the compilation unit file name." (let ((data input) (comp-native-compiling t) (comp-ctxt (make-comp-ctxt - :output (if (symbolp input) - (make-temp-file (concat (symbol-name input) "-")) - (file-name-sans-extension (expand-file-name input)))))) + :output + (if (symbolp input) + (make-temp-file (concat (symbol-name input) "-")) + (let ((exp-file (expand-file-name input))) + (concat + (file-name-as-directory + (concat + (file-name-directory exp-file) + system-configuration)) + (file-name-sans-extension + (file-name-nondirectory exp-file)))))))) (comp-log "\n \n" 1) (condition-case err (mapc (lambda (pass) commit 0da62d94e2a167d5ccfd8ece03623afdc178154c Author: AndreaCorallo Date: Thu Feb 6 20:41:52 2020 +0000 Change parameter name into comp--compile-ctxt-to-file diff --git a/src/comp.c b/src/comp.c index 0b7b2b9261..9dcd5547de 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3212,9 +3212,9 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, Scomp__compile_ctxt_to_file, 1, 1, 0, doc: /* Compile as native code the current context to file. */) - (Lisp_Object ctxtname) + (Lisp_Object base_name) { - CHECK_STRING (ctxtname); + CHECK_STRING (base_name); gcc_jit_context_set_int_option (comp.ctxt, GCC_JIT_INT_OPTION_OPTIMIZATION_LEVEL, @@ -3261,16 +3261,16 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, if (COMP_DEBUG) gcc_jit_context_dump_to_file (comp.ctxt, - format_string ("%s.c", SSDATA (ctxtname)), + format_string ("%s.c", SSDATA (base_name)), 1); if (COMP_DEBUG > 2) gcc_jit_context_dump_reproducer_to_file (comp.ctxt, "comp_reproducer.c"); AUTO_STRING (dot_so, NATIVE_ELISP_SUFFIX); - Lisp_Object out_file = CALLN (Fconcat, ctxtname, dot_so); + Lisp_Object out_file = CALLN (Fconcat, base_name, dot_so); Lisp_Object tmp_file = - Fmake_temp_file_internal (ctxtname, Qnil, dot_so, Qnil); + Fmake_temp_file_internal (base_name, Qnil, dot_so, Qnil); gcc_jit_context_compile_to_file (comp.ctxt, GCC_JIT_OUTPUT_KIND_DYNAMIC_LIBRARY, SSDATA (tmp_file)); commit 0cef208cc32c29b143be262fe673e7518b6ef2a8 Author: Andrea Corallo Date: Sat Feb 29 17:38:50 2020 +0000 * Reorganize passes - Make propagate responsible for keeping SSA up to date. - Run propagate-alloc as very last before final not to risk bothering with mvar array allocation during previous tranformations. - Fix SSA if TCO modify the CFG. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 9037c23a4f..e14f350c2e 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -120,12 +120,12 @@ Can be one of: 'd-default', 'd-impure' or 'd-ephemeral'. See `comp-ctxt'.") (defconst comp-passes '(comp-spill-lap comp-limplify - comp-ssa - comp-propagate-1 + comp-propagate comp-call-optim - comp-propagate-2 + comp-propagate comp-dead-code comp-tco + comp-propagate-alloc comp-final) "Passes to be executed in order.") @@ -1546,7 +1546,7 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non nil." when (eq op 'phi) do (finalize-phi args b))))) -(defun comp-ssa (_) +(defun comp-ssa () "Port all functions into mininal SSA form." (maphash (lambda (_ f) (let* ((comp-func f) @@ -1736,7 +1736,8 @@ Return t if something was changed." do (setf modified t)) finally return modified)) -(defun comp-propagate-iterate (backward) +(defun comp-propagate1 (backward) + (comp-ssa) (when (>= comp-speed 2) (maphash (lambda (_ f) ;; FIXME remove the following condition when tested. @@ -1750,14 +1751,14 @@ Return t if something was changed." (comp-log-func comp-func 3)))) (comp-ctxt-funcs-h comp-ctxt)))) -(defun comp-propagate-1 (_) +(defun comp-propagate (_) "Forward propagate types and consts within the lattice." - (comp-propagate-iterate nil)) + (comp-propagate1 nil)) -(defun comp-propagate-2 (_) +(defun comp-propagate-alloc (_) "Forward propagate types and consts within the lattice. Backward propagate array placement properties." - (comp-propagate-iterate t)) + (comp-propagate1 t)) ;;; Call optimizer pass specific code. commit f60cb02cdfdcf69cc5e463a55f33845b3d862e62 Author: Andrea Corallo Date: Sat Feb 29 17:14:43 2020 +0000 * Allow for multiple SSA runs Add function ssa-status as `comp-func' slot and have `comp-clean-ssa' to run when necessary. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 74d352394f..9037c23a4f 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -237,6 +237,7 @@ into it.") (closed nil :type boolean :documentation "t if closed.") ;; All the followings are for SSA and CGF analysis. + ;; Keep in sync with `comp-clean-ssa'!! (in-edges () :type list :documentation "List of incoming edges.") (out-edges () :type list @@ -283,6 +284,10 @@ Is in use to help the SSA rename pass.")) :documentation "Interactive form.") (lap () :type list :documentation "LAP assembly representation.") + (ssa-status nil :type symbol + :documentation "SSA status either: 'nil', 'dirty' or 't'. +Once in SSA form this *must* be set to 'dirty' every time the topology of the +CFG is mutated by a pass.") (args nil :type comp-args-base) (frame-size nil :type number) (blocks (make-hash-table) :type hash-table @@ -1271,6 +1276,22 @@ Top-level forms for the current context are rendered too." (setf (comp-mvar-id mvar) (sxhash-eq mvar)) mvar)) +(defun comp-clean-ssa (f) + "Clean-up SSA for funtion F." + (setf (comp-func-edges f) ()) + (cl-loop + for b being each hash-value of (comp-func-blocks f) + do (setf (comp-block-in-edges b) () + (comp-block-out-edges b) () + (comp-block-dom b) nil + (comp-block-df b) (make-hash-table) + (comp-block-post-num b) nil + (comp-block-final-frame b) nil + ;; Prune all phis. + (comp-block-insns b) (cl-loop for insn in (comp-block-insns b) + unless (eq 'phi (car insn)) + collect insn)))) + (defun comp-compute-edges () "Compute the basic block edges for the current function." (cl-flet ((edge-add (&rest args) @@ -1523,22 +1544,25 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non nil." (cl-loop for b being each hash-value of (comp-func-blocks comp-func) do (cl-loop for (op . args) in (comp-block-insns b) when (eq op 'phi) - do (finalize-phi args b))))) + do (finalize-phi args b))))) (defun comp-ssa (_) "Port all functions into mininal SSA form." (maphash (lambda (_ f) - (let ((comp-func f)) - ;; TODO: if this is run more than once we should clean all CFG - ;; data including phis here. - (comp-compute-edges) - (comp-compute-dominator-tree) - (comp-compute-dominator-frontiers) - (comp-log-block-info) - (comp-place-phis) - (comp-ssa-rename) - (comp-finalize-phis) - (comp-log-func comp-func 3))) + (let* ((comp-func f) + (ssa-status (comp-func-ssa-status f))) + (unless (eq ssa-status t) + (when (eq ssa-status 'dirty) + (comp-clean-ssa f)) + (comp-compute-edges) + (comp-compute-dominator-tree) + (comp-compute-dominator-frontiers) + (comp-log-block-info) + (comp-place-phis) + (comp-ssa-rename) + (comp-finalize-phis) + (comp-log-func comp-func 3) + (setf (comp-func-ssa-status f) t)))) (comp-ctxt-funcs-h comp-ctxt))) @@ -1928,7 +1952,8 @@ These are substituted with a normal 'set' op." (eq l-val ret-val)) (let ((tco-seq (comp-form-tco-call-seq args))) (setf (car insns-seq) (car tco-seq) - (cdr insns-seq) (cdr tco-seq)) + (cdr insns-seq) (cdr tco-seq) + (comp-func-ssa-status comp-func) 'dirty) (cl-return-from in-the-basic-block)))))))) (defun comp-tco (_) commit b41d76fa5e0bce80a3ef92f30243f9c53b9ac6bc Author: AndreaCorallo Date: Sun Mar 1 14:42:41 2020 +0000 Remove relocation index form LIMPLE setimm Given that every object identify a relocation class simplify setimm too. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 7792605fff..74d352394f 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -665,7 +665,7 @@ If DST-N is specified use it otherwise assume it to be the current slot." (comp-add-const-to-relocs val) ;; Leave relocation index nil on purpose, will be fixed-up in final ;; by `comp-finalize-relocs'. - (comp-emit `(setimm ,(comp-slot) nil ,val))) + (comp-emit `(setimm ,(comp-slot) ,val))) (defun comp-make-curr-block (block-name entry-sp &optional addr) "Create a basic block with BLOCK-NAME and set it as current block. @@ -762,7 +762,7 @@ Return value is the fall through block name." ;; FIXME this not efficient for big jump tables. We should have a second ;; strategy for this case. (pcase last-insn - (`(setimm ,_ ,_ ,jmp-table) + (`(setimm ,_ ,jmp-table) (cl-loop for test being each hash-keys of jmp-table using (hash-value target-label) @@ -1619,7 +1619,7 @@ Here goes everything that can be done not iteratively (read once). (`(,(or 'callref 'direct-callref) ,_f . ,args) (when backward (comp-ref-args-to-array args))) - (`(setimm ,lval ,_ ,v) + (`(setimm ,lval ,v) (setf (comp-mvar-const-vld lval) t (comp-mvar-constant lval) v (comp-mvar-type lval) (comp-strict-type-of v))))))) @@ -1658,7 +1658,7 @@ Here goes everything that can be done not iteratively (read once). ;; See `comp-emit-setimm'. (comp-add-const-to-relocs value) (setf (car insn) 'setimm - (cddr insn) `(nil ,value)))))) + (cddr insn) `(,value)))))) (defun comp-propagate-insn (insn) "Propagate within INSN." diff --git a/src/comp.c b/src/comp.c index bcb0c69986..0b7b2b9261 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1594,9 +1594,9 @@ emit_limple_insn (Lisp_Object insn) } else if (EQ (op, Qsetimm)) { - /* Ex: (setimm #s(comp-mvar 9 1 t 3 nil) 3 a). */ - emit_comment (SSDATA (Fprin1_to_string (arg[2], Qnil))); - imm_reloc_t reloc = obj_to_reloc (arg[2]); + /* Ex: (setimm #s(comp-mvar 9 1 t 3 nil) a). */ + emit_comment (SSDATA (Fprin1_to_string (arg[1], Qnil))); + imm_reloc_t reloc = obj_to_reloc (arg[1]); emit_frame_assignment ( arg[0], gcc_jit_lvalue_as_rvalue ( commit 5543338b0c6245f0d1939d9c2617b65ded59ca3b Author: Andrea Corallo Date: Sat Feb 29 15:53:42 2020 +0000 Optimize relocation classes for object duplication Merge duplicated objects during final. Precendece is: 1 d-default 2 d-impure 3 d-ephemeral Now every object identify uniquely a relocation class. Because of this there's no need to keep the reloc class into m-var. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 6ad97062b4..7792605fff 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -318,10 +318,7 @@ structure.") a value known at compile time.") (type nil :type symbol :documentation "When non nil indicates the type when known at compile - time.") - (alloc-class nil :type symbol - :documentation "Can be one of: 'd-default' 'd-impure' - or 'd-ephemeral'.")) + time.")) ;; Special vars used by some passes (defvar comp-func) @@ -344,31 +341,15 @@ structure.") "Type hint predicate for function name FUNC." (when (memq func comp-type-hints) t)) -(defun comp-data-container-check (cont) - "Sanity check CONT coherency." - (cl-assert (= (length (comp-data-container-l cont)) - (hash-table-count (comp-data-container-idx cont))))) - -(defun comp-add-const-to-relocs-to-cont (obj cont) - "Keep track of OBJ into the CONT relocation container. -The corresponding index is returned." - (let ((h (comp-data-container-idx cont))) - (if-let ((idx (gethash obj h))) - idx - (push obj (comp-data-container-l cont)) - (puthash obj (hash-table-count h) h)))) - (defsubst comp-alloc-class-to-container (alloc-class) "Given ALLOC-CLASS return the data container for the current context. Assume allocaiton class 'd-default as default." (cl-struct-slot-value 'comp-ctxt (or alloc-class 'd-default) comp-ctxt)) -(defun comp-add-const-to-relocs (obj) - "Keep track of OBJ into the ctxt relocations. -The corresponding index is returned." - (comp-add-const-to-relocs-to-cont obj - (comp-alloc-class-to-container - comp-curr-allocation-class))) +(defsubst comp-add-const-to-relocs (obj) + "Keep track of OBJ into the ctxt relocations." + (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. @@ -642,7 +623,7 @@ STACK-OFF is the index of the first slot frame involved." (when const-vld (comp-add-const-to-relocs constant)) (make--comp-mvar :slot slot :const-vld const-vld :constant constant - :type type :alloc-class comp-curr-allocation-class)) + :type type)) (defun comp-new-frame (size &optional ssa) "Return a clean frame of meta variables of size SIZE. @@ -679,11 +660,12 @@ If DST-N is specified use it otherwise assume it to be the current slot." "Emit annotation STR." (comp-emit `(comment ,str))) -(defun comp-emit-setimm (val) +(defsubst comp-emit-setimm (val) "Set constant VAL to current slot." - (let ((rel-idx (comp-add-const-to-relocs val))) - (cl-assert (numberp rel-idx)) - (comp-emit `(setimm ,(comp-slot) ,rel-idx ,val)))) + (comp-add-const-to-relocs val) + ;; Leave relocation index nil on purpose, will be fixed-up in final + ;; by `comp-finalize-relocs'. + (comp-emit `(setimm ,(comp-slot) nil ,val))) (defun comp-make-curr-block (block-name entry-sp &optional addr) "Create a basic block with BLOCK-NAME and set it as current block. @@ -1281,13 +1263,11 @@ Top-level forms for the current context are rendered too." ;; this form is called 'minimal SSA form'. ;; This pass should be run every time basic blocks or m-var are shuffled. -(cl-defun make-comp-ssa-mvar (&key slot (constant nil const-vld) type - (alloc-class comp-curr-allocation-class)) +(cl-defun make-comp-ssa-mvar (&key slot (constant nil const-vld) type) (let ((mvar (make--comp-mvar :slot slot :const-vld const-vld :constant constant - :type type - :alloc-class alloc-class))) + :type type))) (setf (comp-mvar-id mvar) (sxhash-eq mvar)) mvar)) @@ -1674,10 +1654,11 @@ Here goes everything that can be done not iteratively (read once). ;; pruning in order to be sure that this is not dead-code. This ;; is now left to gcc, to be implemented only if we want a ;; reliable diagnostic here. - (let ((values (apply f (mapcar #'comp-mvar-constant args)))) + (let ((value (apply f (mapcar #'comp-mvar-constant args)))) ;; See `comp-emit-setimm'. + (comp-add-const-to-relocs value) (setf (car insn) 'setimm - (cddr insn) (list (comp-add-const-to-relocs values) values)))))) + (cddr insn) `(nil ,value)))))) (defun comp-propagate-insn (insn) "Propagate within INSN." @@ -1967,15 +1948,47 @@ These are substituted with a normal 'set' op." ;;; Final pass specific code. +(defun comp-finalize-container (cont) + "Finalize data container CONT." + (setf (comp-data-container-l cont) + (cl-loop with h = (comp-data-container-idx cont) + for obj each hash-keys of h + for i from 0 + do (puthash obj i h) + collect obj))) + +(defun comp-finalize-relocs () + "Finalize data containers for each relocation class. +Remove immediate duplicates within relocation classes. +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)) + + (let* ((d-default (comp-ctxt-d-default comp-ctxt)) + (d-default-idx (comp-data-container-idx d-default)) + (d-impure (comp-ctxt-d-impure comp-ctxt)) + (d-impure-idx (comp-data-container-idx d-impure)) + (d-ephemeral (comp-ctxt-d-ephemeral comp-ctxt)) + (d-ephemeral-idx (comp-data-container-idx d-ephemeral))) + ;; Remove things in d-impure that are already in d-default. + (cl-loop for obj being each hash-keys of d-impure-idx + when (gethash obj d-default-idx) + do (remhash obj d-impure-idx)) + ;; Remove things in d-ephemeral that are already in d-default or + ;; d-impure. + (cl-loop for obj being each hash-keys of d-ephemeral-idx + when (or (gethash obj d-default-idx) (gethash obj d-impure-idx)) + do (remhash obj d-ephemeral-idx)) + ;; Fix-up indexes in each relocation class and fill corresponding + ;; reloc lists. + (mapc #'comp-finalize-container (list d-default d-impure d-ephemeral)))) + (defun comp-compile-ctxt-to-file (name) "Compile as native code the current context naming it NAME. Prepare every function for final compilation and drive the C back-end." - (comp-data-container-check (comp-ctxt-d-default comp-ctxt)) - (comp-data-container-check (comp-ctxt-d-impure comp-ctxt)) - (comp-data-container-check (comp-ctxt-d-ephemeral comp-ctxt)) - ;; TODO: here we could optimize cleaning up objects present in the - ;; impure and or in the ephemeral container that are also in the - ;; default one. + (comp-finalize-relocs) (unless comp-dry-run (comp--compile-ctxt-to-file name))) diff --git a/src/comp.c b/src/comp.c index 0fc6e41292..bcb0c69986 100644 --- a/src/comp.c +++ b/src/comp.c @@ -185,6 +185,9 @@ typedef struct { gcc_jit_rvalue *data_relocs_ephemeral; /* Synthesized struct holding func relocs. */ gcc_jit_lvalue *func_relocs; + Lisp_Object d_default_idx; + Lisp_Object d_impure_idx; + Lisp_Object d_ephemeral_idx; } comp_t; static comp_t comp; @@ -197,6 +200,11 @@ typedef struct { const char data[]; } static_obj_t; +typedef struct { + gcc_jit_rvalue *array; + gcc_jit_rvalue *idx; +} imm_reloc_t; + /* Helper functions called by the run-time. @@ -387,18 +395,43 @@ register_emitter (Lisp_Object key, void *func) Fputhash (key, value, comp.emitter_dispatcher); } -static gcc_jit_rvalue * -alloc_class_to_reloc (Lisp_Object alloc_class) -{ - if (alloc_class == Qd_default) - return comp.data_relocs; - else if (alloc_class == Qd_impure) - return comp.data_relocs_impure; - else if (alloc_class == Qd_ephemeral) - return comp.data_relocs_ephemeral; - xsignal (Qnative_ice, - build_string ("inconsistent allocation class")); +static imm_reloc_t +obj_to_reloc (Lisp_Object obj) +{ + imm_reloc_t reloc; + Lisp_Object idx; + + idx = Fgethash (obj, comp.d_default_idx, Qnil); + if (!NILP (idx)) { + reloc.array = comp.data_relocs; + goto found; + } + + idx = Fgethash (obj, comp.d_impure_idx, Qnil); + if (!NILP (idx)) + { + reloc.array = comp.data_relocs_impure; + goto found; + } + + idx = Fgethash (obj, comp.d_ephemeral_idx, Qnil); + if (!NILP (idx)) + { + reloc.array = comp.data_relocs_ephemeral; + goto found; + } + + xsignal1 (Qnative_ice, + build_string ("cant't find data in relocation containers")); assume (false); + found: + if (!FIXNUMP (idx)) + xsignal1 (Qnative_ice, + build_string ("inconsistent data relocation container")); + reloc.idx = gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.ptrdiff_type, + XFIXNUM (idx)); + return reloc; } static void @@ -912,7 +945,7 @@ emit_make_fixnum (gcc_jit_rvalue *obj) } static gcc_jit_rvalue * -emit_const_lisp_obj (Lisp_Object obj, Lisp_Object alloc_class) +emit_const_lisp_obj (Lisp_Object obj) { emit_comment (format_string ("const lisp obj: %s", SSDATA (Fprin1_to_string (obj, Qnil)))); @@ -922,28 +955,20 @@ emit_const_lisp_obj (Lisp_Object obj, Lisp_Object alloc_class) gcc_jit_context_new_rvalue_from_ptr (comp.ctxt, comp.void_ptr_type, NULL)); - - Lisp_Object container = CALL1I (comp-alloc-class-to-container, alloc_class); - Lisp_Object reloc_idx = - Fgethash (obj, CALL1I (comp-data-container-idx, container), Qnil); - eassert (!NILP (reloc_idx)); - gcc_jit_rvalue *reloc_n = - gcc_jit_context_new_rvalue_from_int (comp.ctxt, - comp.ptrdiff_type, - XFIXNUM (reloc_idx)); + imm_reloc_t reloc = obj_to_reloc (obj); return gcc_jit_lvalue_as_rvalue ( gcc_jit_context_new_array_access (comp.ctxt, NULL, - alloc_class_to_reloc (alloc_class), - reloc_n)); + reloc.array, + reloc.idx)); } static gcc_jit_rvalue * emit_NILP (gcc_jit_rvalue *x) { emit_comment ("NILP"); - return emit_EQ (x, emit_const_lisp_obj (Qnil, Qd_default)); + return emit_EQ (x, emit_const_lisp_obj (Qnil)); } static gcc_jit_rvalue * @@ -1046,7 +1071,7 @@ emit_CHECK_CONS (gcc_jit_rvalue *x) gcc_jit_rvalue *args[] = { emit_CONSP (x), - emit_const_lisp_obj (Qconsp, Qd_default), + emit_const_lisp_obj (Qconsp), x }; gcc_jit_block_add_eval ( @@ -1157,8 +1182,7 @@ emit_mvar_val (Lisp_Object mvar) return emit_cast (comp.lisp_obj_type, word); } /* Other const objects are fetched from the reloc array. */ - return emit_const_lisp_obj (constant, - CALL1I (comp-mvar-alloc-class, mvar)); + return emit_const_lisp_obj (constant); } return gcc_jit_lvalue_as_rvalue (emit_mvar_access (mvar)); @@ -1193,7 +1217,7 @@ emit_set_internal (Lisp_Object args) gcc_jit_rvalue *gcc_args[4]; FOR_EACH_TAIL (args) gcc_args[i++] = emit_mvar_val (XCAR (args)); - gcc_args[2] = emit_const_lisp_obj (Qnil, Qd_default); + gcc_args[2] = emit_const_lisp_obj (Qnil); gcc_args[3] = gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.int_type, SET_INTERNAL_SET); @@ -1571,20 +1595,15 @@ emit_limple_insn (Lisp_Object insn) else if (EQ (op, Qsetimm)) { /* Ex: (setimm #s(comp-mvar 9 1 t 3 nil) 3 a). */ - gcc_jit_rvalue *reloc_n = - gcc_jit_context_new_rvalue_from_int (comp.ctxt, - comp.int_type, - XFIXNUM (arg[1])); emit_comment (SSDATA (Fprin1_to_string (arg[2], Qnil))); + imm_reloc_t reloc = obj_to_reloc (arg[2]); emit_frame_assignment ( arg[0], gcc_jit_lvalue_as_rvalue ( gcc_jit_context_new_array_access (comp.ctxt, NULL, - alloc_class_to_reloc ( - CALL1I (comp-mvar-alloc-class, - arg[0])), - reloc_n))); + reloc.array, + reloc.idx))); } else if (EQ (op, Qcomment)) { @@ -1807,7 +1826,7 @@ declare_imported_data_relocs (Lisp_Object container, const char *code_symbol, EMACS_INT d_reloc_len = XFIXNUM (CALL1I (hash-table-count, CALL1I (comp-data-container-idx, container))); - Lisp_Object d_reloc = Fnreverse (CALL1I (comp-data-container-l, container)); + Lisp_Object d_reloc = CALL1I (comp-data-container-l, container); d_reloc = Fvconcat (1, &d_reloc); gcc_jit_rvalue *reloc_struct = @@ -1830,12 +1849,6 @@ declare_imported_data_relocs (Lisp_Object container, const char *code_symbol, static void declare_imported_data (void) { - /* Imported symbols by inliner functions. */ - CALL1I (comp-add-const-to-relocs, Qnil); - CALL1I (comp-add-const-to-relocs, Qt); - CALL1I (comp-add-const-to-relocs, Qconsp); - CALL1I (comp-add-const-to-relocs, Qlistp); - /* Imported objects. */ comp.data_relocs = declare_imported_data_relocs (CALL1I (comp-ctxt-d-default, Vcomp_ctxt), @@ -2449,11 +2462,11 @@ define_CAR_CDR (void) comp.block = is_nil_b; gcc_jit_block_end_with_return (comp.block, NULL, - emit_const_lisp_obj (Qnil, Qd_default)); + emit_const_lisp_obj (Qnil)); comp.block = not_nil_b; gcc_jit_rvalue *wrong_type_args[] = - { emit_const_lisp_obj (Qlistp, Qd_default), c }; + { emit_const_lisp_obj (Qlistp), c }; gcc_jit_block_add_eval (comp.block, NULL, @@ -2462,7 +2475,7 @@ define_CAR_CDR (void) false)); gcc_jit_block_end_with_return (comp.block, NULL, - emit_const_lisp_obj (Qnil, Qd_default)); + emit_const_lisp_obj (Qnil)); } comp.car = func[0]; comp.cdr = func[1]; @@ -2842,12 +2855,12 @@ define_bool_to_lisp_obj (void) comp.block = ret_t_block; gcc_jit_block_end_with_return (ret_t_block, NULL, - emit_const_lisp_obj (Qt, Qd_default)); + emit_const_lisp_obj (Qt)); comp.block = ret_nil_block; gcc_jit_block_end_with_return (ret_nil_block, NULL, - emit_const_lisp_obj (Qnil, Qd_default)); + emit_const_lisp_obj (Qnil)); } /* Declare a function being compiled and add it to comp.exported_funcs_h. */ @@ -3206,8 +3219,14 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, gcc_jit_context_set_int_option (comp.ctxt, GCC_JIT_INT_OPTION_OPTIMIZATION_LEVEL, SPEED); - sigset_t oldset; + comp.d_default_idx = + CALL1I (comp-data-container-idx, CALL1I (comp-ctxt-d-default, Vcomp_ctxt)); + comp.d_impure_idx = + CALL1I (comp-data-container-idx, CALL1I (comp-ctxt-d-impure, Vcomp_ctxt)); + comp.d_ephemeral_idx = + CALL1I (comp-data-container-idx, CALL1I (comp-ctxt-d-ephemeral, Vcomp_ctxt)); + sigset_t oldset; if (!noninteractive) { sigset_t blocked; @@ -3231,8 +3250,8 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, define_add1_sub1 (); define_negate (); - struct Lisp_Hash_Table *func_h - = XHASH_TABLE (CALL1I (comp-ctxt-funcs-h, Vcomp_ctxt)); + struct Lisp_Hash_Table *func_h = + XHASH_TABLE (CALL1I (comp-ctxt-funcs-h, Vcomp_ctxt)); for (ptrdiff_t i = 0; i < func_h->count; i++) declare_function (HASH_VALUE (func_h, i)); /* Compile all functions. Can't be done before because the commit b7f36249246a8f80924806593afcf55ab3baca2a Author: Andrea Corallo Date: Sat Feb 29 14:12:21 2020 +0000 * Rename comp-emit-set-const -> comp-emit-setimm diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 3c993c5c93..6ad97062b4 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -679,7 +679,7 @@ If DST-N is specified use it otherwise assume it to be the current slot." "Emit annotation STR." (comp-emit `(comment ,str))) -(defun comp-emit-set-const (val) +(defun comp-emit-setimm (val) "Set constant VAL to current slot." (let ((rel-idx (comp-add-const-to-relocs val))) (cl-assert (numberp rel-idx)) @@ -1086,7 +1086,7 @@ the annotation emission." (cl-second (comp-block-insns (comp-limplify-curr-block comp-pass))))) (byte-constant - (comp-emit-set-const arg)) + (comp-emit-setimm arg)) (byte-discardN-preserve-tos (cl-incf (comp-sp) (- arg)) (comp-copy-slot (+ arg (comp-sp))))))) @@ -1112,7 +1112,7 @@ the annotation emission." (intern (format "entry_fallback_%s" (1+ i)))) do (comp-with-sp i (comp-make-curr-block bb (comp-sp)) - (comp-emit-set-const nil) + (comp-emit-setimm nil) (comp-emit `(jump ,next-bb))))) (comp-make-curr-block 'entry_rest_args (comp-sp)) (comp-emit `(set-rest-args-to-local ,(comp-slot-n nonrest))) @@ -1675,7 +1675,7 @@ Here goes everything that can be done not iteratively (read once). ;; is now left to gcc, to be implemented only if we want a ;; reliable diagnostic here. (let ((values (apply f (mapcar #'comp-mvar-constant args)))) - ;; See `comp-emit-set-const'. + ;; See `comp-emit-setimm'. (setf (car insn) 'setimm (cddr insn) (list (comp-add-const-to-relocs values) values)))))) commit 62384df2656c0a57cdc07ac5397e22fa450a7de1 Author: Andrea Corallo Date: Sat Feb 29 11:05:46 2020 +0000 * Reduce stack depth while marking native compiled subrs diff --git a/src/alloc.c b/src/alloc.c index 354c6f09cc..9a01edca3f 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -6683,7 +6683,9 @@ mark_object (Lisp_Object arg) { set_vector_marked (ptr); struct Lisp_Subr *subr = XSUBR (obj); - mark_object (subr->native_comp_u[0]); + obj = subr->native_comp_u[0]; + eassert (obj); + goto loop; } break; commit 6664f98821d46347a328337c7bcccac3f75c05e3 Merge: 86cc9377ce 13a69c829e Author: Andrea Corallo Date: Sun Mar 1 19:21:38 2020 +0000 Merge remote-tracking branch 'savannah/master' into HEAD commit 86cc9377cec397884744fcc4d0e5b555cbc3ca46 Author: AndreaCorallo Date: Tue Feb 25 22:41:59 2020 +0000 * ; Add a TODO for a future optimization diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index d34ff3c0c8..3c993c5c93 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1973,6 +1973,9 @@ Prepare every function for final compilation and drive the C back-end." (comp-data-container-check (comp-ctxt-d-default comp-ctxt)) (comp-data-container-check (comp-ctxt-d-impure comp-ctxt)) (comp-data-container-check (comp-ctxt-d-ephemeral comp-ctxt)) + ;; TODO: here we could optimize cleaning up objects present in the + ;; impure and or in the ephemeral container that are also in the + ;; default one. (unless comp-dry-run (comp--compile-ctxt-to-file name))) commit 511415f6f656a5bf4da4f5f49d58de9dc7d5d64d Author: AndreaCorallo Date: Tue Feb 25 22:37:20 2020 +0000 Store optimize qualities into .eln files For now just comp-speed and comp-debug are stored. diff --git a/src/comp.c b/src/comp.c index 9855e35278..0fc6e41292 100644 --- a/src/comp.c +++ b/src/comp.c @@ -47,6 +47,7 @@ along with GNU Emacs. If not, see . */ #define TEXT_DATA_RELOC_SYM "text_data_reloc" #define TEXT_DATA_RELOC_IMPURE_SYM "text_data_reloc_imp" #define TEXT_DATA_RELOC_EPHEMERAL_SYM "text_data_reloc_eph" +#define TEXT_OPTIM_QLY "text_optim_qly" #define SPEED XFIXNUM (Fsymbol_value (Qcomp_speed)) #define COMP_DEBUG XFIXNUM (Fsymbol_value (Qcomp_debug)) @@ -1915,6 +1916,14 @@ declare_runtime_imported_funcs (void) static void emit_ctxt_code (void) { + /* Emit optimize qualities. */ + Lisp_Object opt_qly[] = + { Fcons (Qcomp_speed, + Fsymbol_value (Qcomp_speed)), + Fcons (Qcomp_debug, + Fsymbol_value (Qcomp_debug)) }; + emit_static_object (TEXT_OPTIM_QLY, Flist (2, opt_qly)); + comp.current_thread_ref = gcc_jit_lvalue_as_rvalue ( gcc_jit_context_new_global ( @@ -3414,6 +3423,7 @@ load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u, bool loading_dump) /* Imported data. */ if (!loading_dump) { + comp_u->optimize_qualities = load_static_obj (comp_u, TEXT_OPTIM_QLY); comp_u->data_vec = load_static_obj (comp_u, TEXT_DATA_RELOC_SYM); comp_u->data_impure_vec = load_static_obj (comp_u, TEXT_DATA_RELOC_IMPURE_SYM); diff --git a/src/comp.h b/src/comp.h index 6019831bc3..3aff440ecb 100644 --- a/src/comp.h +++ b/src/comp.h @@ -36,6 +36,7 @@ struct Lisp_Native_Comp_Unit union vectorlike_header header; /* Original eln file loaded. */ Lisp_Object file; + Lisp_Object optimize_qualities; /* Analogous to the constant vector but per compilation unit. */ Lisp_Object data_vec; /* Same but for data that cannot be moved to pure space. diff --git a/src/print.c b/src/print.c index ce8dd625b6..9b8308a675 100644 --- a/src/print.c +++ b/src/print.c @@ -1840,8 +1840,11 @@ print_vectorlike (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag, #ifdef HAVE_NATIVE_COMP case PVEC_NATIVE_COMP_UNIT: { - print_c_string ("#file, printcharfun); + struct Lisp_Native_Comp_Unit *cu = XNATIVE_COMP_UNIT (obj); + print_c_string ("#file, printcharfun); + printchar (' ', printcharfun); + print_object (cu->optimize_qualities, printcharfun, escapeflag); printchar ('>', printcharfun); } break; commit 6898161a2b4d6af2d4b4b8f20a813304938bed53 Author: AndreaCorallo Date: Tue Feb 25 21:39:59 2020 +0000 Rename d-base allocation classe into d-default diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 000f266ba2..d34ff3c0c8 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -114,9 +114,9 @@ Can be used by code that wants to expand differently in this case.") (defvar comp-pass nil "Every pass has the right to bind what it likes here.") -(defvar comp-curr-allocation-class 'd-base +(defvar comp-curr-allocation-class 'd-default "Current allocation class. -Can be one of: 'd-base', '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 @@ -196,7 +196,7 @@ Can be one of: 'd-base', 'd-impure' or 'd-ephemeral'. See `comp-ctxt'.") (funcs-h (make-hash-table) :type hash-table :documentation "lisp-func-name -> comp-func. This is to build the prev field.") - (d-base (make-comp-data-container) :type comp-data-container + (d-default (make-comp-data-container) :type comp-data-container :documentation "Standard data relocated in use by functions.") (d-impure (make-comp-data-container) :type comp-data-container :documentation "Relocated data that cannot be moved into pure space. @@ -320,7 +320,7 @@ structure.") :documentation "When non nil indicates the type when known at compile time.") (alloc-class nil :type symbol - :documentation "Can be one of: 'd-base' 'd-impure' + :documentation "Can be one of: 'd-default' 'd-impure' or 'd-ephemeral'.")) ;; Special vars used by some passes @@ -360,8 +360,8 @@ The corresponding index is returned." (defsubst comp-alloc-class-to-container (alloc-class) "Given ALLOC-CLASS return the data container for the current context. -Assume allocaiton class 'd-base as default." - (cl-struct-slot-value 'comp-ctxt (or alloc-class 'd-base) comp-ctxt)) +Assume allocaiton class 'd-default as default." + (cl-struct-slot-value 'comp-ctxt (or alloc-class 'd-default) comp-ctxt)) (defun comp-add-const-to-relocs (obj) "Keep track of OBJ into the ctxt relocations. @@ -1970,7 +1970,7 @@ These are substituted with a normal 'set' op." (defun comp-compile-ctxt-to-file (name) "Compile as native code the current context naming it NAME. Prepare every function for final compilation and drive the C back-end." - (comp-data-container-check (comp-ctxt-d-base comp-ctxt)) + (comp-data-container-check (comp-ctxt-d-default comp-ctxt)) (comp-data-container-check (comp-ctxt-d-impure comp-ctxt)) (comp-data-container-check (comp-ctxt-d-ephemeral comp-ctxt)) (unless comp-dry-run diff --git a/src/comp.c b/src/comp.c index b6de0ece36..9855e35278 100644 --- a/src/comp.c +++ b/src/comp.c @@ -389,7 +389,7 @@ register_emitter (Lisp_Object key, void *func) static gcc_jit_rvalue * alloc_class_to_reloc (Lisp_Object alloc_class) { - if (alloc_class == Qd_base) + if (alloc_class == Qd_default) return comp.data_relocs; else if (alloc_class == Qd_impure) return comp.data_relocs_impure; @@ -942,7 +942,7 @@ static gcc_jit_rvalue * emit_NILP (gcc_jit_rvalue *x) { emit_comment ("NILP"); - return emit_EQ (x, emit_const_lisp_obj (Qnil, Qd_base)); + return emit_EQ (x, emit_const_lisp_obj (Qnil, Qd_default)); } static gcc_jit_rvalue * @@ -1045,7 +1045,7 @@ emit_CHECK_CONS (gcc_jit_rvalue *x) gcc_jit_rvalue *args[] = { emit_CONSP (x), - emit_const_lisp_obj (Qconsp, Qd_base), + emit_const_lisp_obj (Qconsp, Qd_default), x }; gcc_jit_block_add_eval ( @@ -1192,7 +1192,7 @@ emit_set_internal (Lisp_Object args) gcc_jit_rvalue *gcc_args[4]; FOR_EACH_TAIL (args) gcc_args[i++] = emit_mvar_val (XCAR (args)); - gcc_args[2] = emit_const_lisp_obj (Qnil, Qd_base); + gcc_args[2] = emit_const_lisp_obj (Qnil, Qd_default); gcc_args[3] = gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.int_type, SET_INTERNAL_SET); @@ -1837,7 +1837,7 @@ declare_imported_data (void) /* Imported objects. */ comp.data_relocs = - declare_imported_data_relocs (CALL1I (comp-ctxt-d-base, Vcomp_ctxt), + declare_imported_data_relocs (CALL1I (comp-ctxt-d-default, Vcomp_ctxt), DATA_RELOC_SYM, TEXT_DATA_RELOC_SYM); comp.data_relocs_impure = @@ -2440,11 +2440,11 @@ define_CAR_CDR (void) comp.block = is_nil_b; gcc_jit_block_end_with_return (comp.block, NULL, - emit_const_lisp_obj (Qnil, Qd_base)); + emit_const_lisp_obj (Qnil, Qd_default)); comp.block = not_nil_b; gcc_jit_rvalue *wrong_type_args[] = - { emit_const_lisp_obj (Qlistp, Qd_base), c }; + { emit_const_lisp_obj (Qlistp, Qd_default), c }; gcc_jit_block_add_eval (comp.block, NULL, @@ -2453,7 +2453,7 @@ define_CAR_CDR (void) false)); gcc_jit_block_end_with_return (comp.block, NULL, - emit_const_lisp_obj (Qnil, Qd_base)); + emit_const_lisp_obj (Qnil, Qd_default)); } comp.car = func[0]; comp.cdr = func[1]; @@ -2833,12 +2833,12 @@ define_bool_to_lisp_obj (void) comp.block = ret_t_block; gcc_jit_block_end_with_return (ret_t_block, NULL, - emit_const_lisp_obj (Qt, Qd_base)); + emit_const_lisp_obj (Qt, Qd_default)); comp.block = ret_nil_block; gcc_jit_block_end_with_return (ret_nil_block, NULL, - emit_const_lisp_obj (Qnil, Qd_base)); + emit_const_lisp_obj (Qnil, Qd_default)); } /* Declare a function being compiled and add it to comp.exported_funcs_h. */ @@ -3554,7 +3554,7 @@ syms_of_comp (void) DEFSYM (Qintegerp, "integerp"); /* Allocation classes. */ - DEFSYM (Qd_base, "d-base"); + DEFSYM (Qd_default, "d-default"); DEFSYM (Qd_impure, "d-impure"); DEFSYM (Qd_ephemeral, "d-ephemeral"); commit 94dcb69256a0daea2c51540217c3abdc2fd50552 Author: AndreaCorallo Date: Tue Feb 25 22:35:02 2020 +0000 Add ephemeral relocation data class Add a new class of relocated objects that is in use just during load process. This in order to avoid having to maintain them in the heap and traverse them at every GC. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 7054c58899..000f266ba2 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -32,6 +32,7 @@ (require 'gv) (require 'cl-lib) (require 'cl-extra) +(require 'cl-macs) (require 'subr-x) (defgroup comp nil @@ -113,7 +114,9 @@ Can be used by code that wants to expand differently in this case.") (defvar comp-pass nil "Every pass has the right to bind what it likes here.") -(defvar comp-emitting-impure nil "Non nil to emit only impure objects.") +(defvar comp-curr-allocation-class 'd-base + "Current allocation class. +Can be one of: 'd-base', 'd-impure' or 'd-ephemeral'. See `comp-ctxt'.") (defconst comp-passes '(comp-spill-lap comp-limplify @@ -196,8 +199,10 @@ This is to build the prev field.") (d-base (make-comp-data-container) :type comp-data-container :documentation "Standard data relocated in use by functions.") (d-impure (make-comp-data-container) :type comp-data-container - :documentation "Data relocated that cannot be moved into pure space. -This is tipically for top-level forms other than defun.")) + :documentation "Relocated data that cannot be moved into pure space. +This is tipically for top-level forms other than defun.") + (d-ephemeral (make-comp-data-container) :type comp-data-container + :documentation "Relocated data not necessary after load.")) (cl-defstruct comp-args-base (min nil :type number @@ -314,8 +319,9 @@ structure.") (type nil :type symbol :documentation "When non nil indicates the type when known at compile time.") - (impure nil :type boolean - :documentation "When non nil can't be copied into pure space.")) + (alloc-class nil :type symbol + :documentation "Can be one of: 'd-base' 'd-impure' + or 'd-ephemeral'.")) ;; Special vars used by some passes (defvar comp-func) @@ -352,13 +358,17 @@ The corresponding index is returned." (push obj (comp-data-container-l cont)) (puthash obj (hash-table-count h) h)))) +(defsubst comp-alloc-class-to-container (alloc-class) + "Given ALLOC-CLASS return the data container for the current context. +Assume allocaiton class 'd-base as default." + (cl-struct-slot-value 'comp-ctxt (or alloc-class 'd-base) comp-ctxt)) + (defun comp-add-const-to-relocs (obj) "Keep track of OBJ into the ctxt relocations. The corresponding index is returned." (comp-add-const-to-relocs-to-cont obj - (if comp-emitting-impure - (comp-ctxt-d-impure comp-ctxt) - (comp-ctxt-d-base comp-ctxt)))) + (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. @@ -632,7 +642,7 @@ STACK-OFF is the index of the first slot frame involved." (when const-vld (comp-add-const-to-relocs constant)) (make--comp-mvar :slot slot :const-vld const-vld :constant constant - :type type :impure comp-emitting-impure)) + :type type :alloc-class comp-curr-allocation-class)) (defun comp-new-frame (size &optional ssa) "Return a clean frame of meta variables of size SIZE. @@ -1143,7 +1153,7 @@ the annotation emission." (cl-defmethod comp-emit-for-top-level ((form byte-to-native-top-level)) (let ((form (byte-to-native-top-level-form form))) (comp-emit (comp-call 'eval - (let ((comp-emitting-impure t)) + (let ((comp-curr-allocation-class 'd-impure)) (make-comp-mvar :constant form)) (make-comp-mvar :constant t))))) @@ -1158,7 +1168,7 @@ into the C code forwarding the compilation unit." ;; Once an .eln is loaded and Emacs is dumped 'top_level_run' has no ;; reasons to be execute ever again. Therefore all objects can be ;; just impure. - (let* ((comp-emitting-impure t) + (let* ((comp-curr-allocation-class 'd-impure) (func (make-comp-func :name 'top-level-run :c-name "top_level_run" :args (make-comp-args :min 1 :max 1) @@ -1271,11 +1281,13 @@ Top-level forms for the current context are rendered too." ;; this form is called 'minimal SSA form'. ;; This pass should be run every time basic blocks or m-var are shuffled. -(cl-defun make-comp-ssa-mvar (&key slot (constant nil const-vld) type) +(cl-defun make-comp-ssa-mvar (&key slot (constant nil const-vld) type + (alloc-class comp-curr-allocation-class)) (let ((mvar (make--comp-mvar :slot slot :const-vld const-vld :constant constant - :type type))) + :type type + :alloc-class alloc-class))) (setf (comp-mvar-id mvar) (sxhash-eq mvar)) mvar)) @@ -1960,6 +1972,7 @@ These are substituted with a normal 'set' op." Prepare every function for final compilation and drive the C back-end." (comp-data-container-check (comp-ctxt-d-base comp-ctxt)) (comp-data-container-check (comp-ctxt-d-impure comp-ctxt)) + (comp-data-container-check (comp-ctxt-d-ephemeral comp-ctxt)) (unless comp-dry-run (comp--compile-ctxt-to-file name))) diff --git a/src/comp.c b/src/comp.c index 2f24b10bba..b6de0ece36 100644 --- a/src/comp.c +++ b/src/comp.c @@ -40,11 +40,13 @@ along with GNU Emacs. If not, see . */ #define PURE_RELOC_SYM "pure_reloc" #define DATA_RELOC_SYM "d_reloc" #define DATA_RELOC_IMPURE_SYM "d_reloc_imp" +#define DATA_RELOC_EPHEMERAL_SYM "d_reloc_eph" #define FUNC_LINK_TABLE_SYM "freloc_link_table" #define LINK_TABLE_HASH_SYM "freloc_hash" #define COMP_UNIT_SYM "comp_unit" #define TEXT_DATA_RELOC_SYM "text_data_reloc" #define TEXT_DATA_RELOC_IMPURE_SYM "text_data_reloc_imp" +#define TEXT_DATA_RELOC_EPHEMERAL_SYM "text_data_reloc_eph" #define SPEED XFIXNUM (Fsymbol_value (Qcomp_speed)) #define COMP_DEBUG XFIXNUM (Fsymbol_value (Qcomp_debug)) @@ -178,6 +180,8 @@ typedef struct { gcc_jit_rvalue *data_relocs; /* Same as before but can't go in pure space. */ gcc_jit_rvalue *data_relocs_impure; + /* Same as before but content does not survive load phase. */ + gcc_jit_rvalue *data_relocs_ephemeral; /* Synthesized struct holding func relocs. */ gcc_jit_lvalue *func_relocs; } comp_t; @@ -382,6 +386,20 @@ register_emitter (Lisp_Object key, void *func) Fputhash (key, value, comp.emitter_dispatcher); } +static gcc_jit_rvalue * +alloc_class_to_reloc (Lisp_Object alloc_class) +{ + if (alloc_class == Qd_base) + return comp.data_relocs; + else if (alloc_class == Qd_impure) + return comp.data_relocs_impure; + else if (alloc_class == Qd_ephemeral) + return comp.data_relocs_ephemeral; + xsignal (Qnative_ice, + build_string ("inconsistent allocation class")); + assume (false); +} + static void emit_comment (const char *str) { @@ -893,7 +911,7 @@ emit_make_fixnum (gcc_jit_rvalue *obj) } static gcc_jit_rvalue * -emit_const_lisp_obj (Lisp_Object obj, Lisp_Object impure) +emit_const_lisp_obj (Lisp_Object obj, Lisp_Object alloc_class) { emit_comment (format_string ("const lisp obj: %s", SSDATA (Fprin1_to_string (obj, Qnil)))); @@ -904,8 +922,7 @@ emit_const_lisp_obj (Lisp_Object obj, Lisp_Object impure) comp.void_ptr_type, NULL)); - Lisp_Object container = impure ? CALL1I (comp-ctxt-d-impure, Vcomp_ctxt) - : CALL1I (comp-ctxt-d-base, Vcomp_ctxt); + Lisp_Object container = CALL1I (comp-alloc-class-to-container, alloc_class); Lisp_Object reloc_idx = Fgethash (obj, CALL1I (comp-data-container-idx, container), Qnil); eassert (!NILP (reloc_idx)); @@ -917,8 +934,7 @@ emit_const_lisp_obj (Lisp_Object obj, Lisp_Object impure) gcc_jit_lvalue_as_rvalue ( gcc_jit_context_new_array_access (comp.ctxt, NULL, - impure ? comp.data_relocs_impure - : comp.data_relocs, + alloc_class_to_reloc (alloc_class), reloc_n)); } @@ -926,7 +942,7 @@ static gcc_jit_rvalue * emit_NILP (gcc_jit_rvalue *x) { emit_comment ("NILP"); - return emit_EQ (x, emit_const_lisp_obj (Qnil, Qnil)); + return emit_EQ (x, emit_const_lisp_obj (Qnil, Qd_base)); } static gcc_jit_rvalue * @@ -1029,7 +1045,7 @@ emit_CHECK_CONS (gcc_jit_rvalue *x) gcc_jit_rvalue *args[] = { emit_CONSP (x), - emit_const_lisp_obj (Qconsp, Qnil), + emit_const_lisp_obj (Qconsp, Qd_base), x }; gcc_jit_block_add_eval ( @@ -1140,7 +1156,8 @@ emit_mvar_val (Lisp_Object mvar) return emit_cast (comp.lisp_obj_type, word); } /* Other const objects are fetched from the reloc array. */ - return emit_const_lisp_obj (constant, CALL1I (comp-mvar-impure, mvar)); + return emit_const_lisp_obj (constant, + CALL1I (comp-mvar-alloc-class, mvar)); } return gcc_jit_lvalue_as_rvalue (emit_mvar_access (mvar)); @@ -1175,7 +1192,7 @@ emit_set_internal (Lisp_Object args) gcc_jit_rvalue *gcc_args[4]; FOR_EACH_TAIL (args) gcc_args[i++] = emit_mvar_val (XCAR (args)); - gcc_args[2] = emit_const_lisp_obj (Qnil, Qnil); + gcc_args[2] = emit_const_lisp_obj (Qnil, Qd_base); gcc_args[3] = gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.int_type, SET_INTERNAL_SET); @@ -1563,7 +1580,9 @@ emit_limple_insn (Lisp_Object insn) gcc_jit_lvalue_as_rvalue ( gcc_jit_context_new_array_access (comp.ctxt, NULL, - comp.data_relocs, + alloc_class_to_reloc ( + CALL1I (comp-mvar-alloc-class, + arg[0])), reloc_n))); } else if (EQ (op, Qcomment)) @@ -1825,6 +1844,10 @@ declare_imported_data (void) declare_imported_data_relocs (CALL1I (comp-ctxt-d-impure, Vcomp_ctxt), DATA_RELOC_IMPURE_SYM, TEXT_DATA_RELOC_IMPURE_SYM); + comp.data_relocs_ephemeral = + declare_imported_data_relocs (CALL1I (comp-ctxt-d-ephemeral, Vcomp_ctxt), + DATA_RELOC_EPHEMERAL_SYM, + TEXT_DATA_RELOC_EPHEMERAL_SYM); } /* @@ -2417,11 +2440,11 @@ define_CAR_CDR (void) comp.block = is_nil_b; gcc_jit_block_end_with_return (comp.block, NULL, - emit_const_lisp_obj (Qnil, Qnil)); + emit_const_lisp_obj (Qnil, Qd_base)); comp.block = not_nil_b; gcc_jit_rvalue *wrong_type_args[] = - { emit_const_lisp_obj (Qlistp, Qnil), c }; + { emit_const_lisp_obj (Qlistp, Qd_base), c }; gcc_jit_block_add_eval (comp.block, NULL, @@ -2430,7 +2453,7 @@ define_CAR_CDR (void) false)); gcc_jit_block_end_with_return (comp.block, NULL, - emit_const_lisp_obj (Qnil, Qnil)); + emit_const_lisp_obj (Qnil, Qd_base)); } comp.car = func[0]; comp.cdr = func[1]; @@ -2810,13 +2833,12 @@ define_bool_to_lisp_obj (void) comp.block = ret_t_block; gcc_jit_block_end_with_return (ret_t_block, NULL, - emit_const_lisp_obj (Qt, Qnil)); + emit_const_lisp_obj (Qt, Qd_base)); comp.block = ret_nil_block; gcc_jit_block_end_with_return (ret_nil_block, NULL, - emit_const_lisp_obj (Qnil, Qnil)); - + emit_const_lisp_obj (Qnil, Qd_base)); } /* Declare a function being compiled and add it to comp.exported_funcs_h. */ @@ -3358,12 +3380,25 @@ load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u, bool loading_dump) EMACS_INT ***pure_reloc = dynlib_sym (handle, PURE_RELOC_SYM); Lisp_Object *data_relocs = dynlib_sym (handle, DATA_RELOC_SYM); Lisp_Object *data_imp_relocs = dynlib_sym (handle, DATA_RELOC_IMPURE_SYM); + Lisp_Object *data_eph_relocs = + dynlib_sym (handle, DATA_RELOC_EPHEMERAL_SYM); void **freloc_link_table = dynlib_sym (handle, FUNC_LINK_TABLE_SYM); + Lisp_Object volatile data_ephemeral_vec; + + /* Note: data_ephemeral_vec is not GC protected except than by + this function frame. After this functions will be + deactivated GC will be free to collect it, but it MUST + survive till 'top_level_run' has finished his job. We store + into the ephemeral allocation class only objects that we know + are necessary exclusively during the first load. Once these + are collected we don't have to maintain them in the heap + forever. */ if (!(current_thread_reloc && pure_reloc && data_relocs && data_imp_relocs + && data_eph_relocs && freloc_link_table && top_level_run) || NILP (Fstring_equal (load_static_obj (comp_u, LINK_TABLE_HASH_SYM), @@ -3382,6 +3417,12 @@ load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u, bool loading_dump) comp_u->data_vec = load_static_obj (comp_u, TEXT_DATA_RELOC_SYM); comp_u->data_impure_vec = load_static_obj (comp_u, TEXT_DATA_RELOC_IMPURE_SYM); + data_ephemeral_vec = + load_static_obj (comp_u, TEXT_DATA_RELOC_EPHEMERAL_SYM); + + EMACS_INT d_vec_len = XFIXNUM (Flength (data_ephemeral_vec)); + for (EMACS_INT i = 0; i < d_vec_len; i++) + data_eph_relocs[i] = AREF (data_ephemeral_vec, i); if (!NILP (Vpurify_flag)) /* Non impure can be copied into pure space. */ @@ -3512,6 +3553,11 @@ syms_of_comp (void) DEFSYM (Qnumberp, "numberp"); DEFSYM (Qintegerp, "integerp"); + /* Allocation classes. */ + DEFSYM (Qd_base, "d-base"); + DEFSYM (Qd_impure, "d-impure"); + DEFSYM (Qd_ephemeral, "d-ephemeral"); + /* Others. */ DEFSYM (Qfixnum, "fixnum"); DEFSYM (Qscratch, "scratch"); commit f0daf1292ccfd6f07b8ded28e29f01919c43022e Author: Andrea Corallo Date: Mon Feb 24 09:32:51 2020 +0000 * Two grammar fixes into async hooks doc diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index af7963289d..7054c58899 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -85,7 +85,7 @@ performed at `comp-speed' > 0." (defcustom comp-async-cu-done-hook nil "This hook is run whenever an asyncronous native compilation -finish compiling a single compilation unit. +finishes compiling a single compilation unit. The argument FILE passed to the function is the filename used as compilation input." :type 'hook @@ -93,7 +93,7 @@ compilation input." (defcustom comp-async-all-done-hook nil "This hook is run whenever the asyncronous native compilation -finished compiling all input files." +finishes compiling all input files." :type 'hook :group 'comp) commit 3e1ec5d87de2953a8ba0d08602a45b050641ef47 Merge: 48b131c6d1 4a94881345 Author: Andrea Corallo Date: Wed Feb 26 10:39:15 2020 +0000 Merge remote-tracking branch 'savannah/master' into HEAD commit 48b131c6d17383eed4b09634e4dddf226b0cd3cd Author: Andrea Corallo Date: Sun Feb 23 14:49:46 2020 +0000 * Add two hooks for async native compilation diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index c13844c70b..af7963289d 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -83,6 +83,20 @@ performed at `comp-speed' > 0." :type 'list :group 'comp) +(defcustom comp-async-cu-done-hook nil + "This hook is run whenever an asyncronous native compilation +finish compiling a single compilation unit. +The argument FILE passed to the function is the filename used as +compilation input." + :type 'hook + :group 'comp) + +(defcustom comp-async-all-done-hook nil + "This hook is run whenever the asyncronous native compilation +finished compiling all input files." + :type 'hook + :group 'comp) + (defvar comp-dry-run nil "When non nil run everything but the C back-end.") @@ -2016,6 +2030,9 @@ Prepare every function for final compilation and drive the C back-end." "--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) @@ -2023,6 +2040,7 @@ Prepare every function for final compilation and drive the C back-end." (when (cl-notany #'process-live-p comp-prc-pool) (let ((msg "Compilation finished.")) (setf comp-prc-pool ()) + (run-hooks 'comp-async-all-done-hook) (with-current-buffer (get-buffer-create comp-async-buffer-name) (save-excursion (goto-char (point-max)) commit 1dc237f280702d959216916b236cb9bf9bbcb22c Author: Andrea Corallo Date: Sun Feb 23 14:06:59 2020 +0000 Make build process robust against interruptions During boo-strap we produce both the .eln and the .elc together. Because the make target is the later this has to be produced as last to be resilient to build interruptions. diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 1f64626a99..b3bd6879b6 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -571,13 +571,19 @@ Each element is (INDEX . VALUE)") form) (defvar byte-native-compiling nil "Non nil while native compiling.") -(defvar byte-native-always-write-elc nil - "Always write the elc file also while native compiling.") +(defvar byte-native-for-bootstrap nil + "Non nil while compiling for bootstrap." + ;; During boostrap we produce both the .eln and the .elc together. + ;; Because the make target is the later this has to be produced as + ;; last to be resilient against build interruptions. +) (defvar byte-to-native-lap nil "A-list to accumulate LAP. Each pair is (NAME . LAP)") (defvar byte-to-native-top-level-forms nil "List of top level forms.") +(defvar byte-to-native-output-file nil + "Temporary file containing the byte-compilation output.") ;;; The byte codes; this information is duplicated in bytecomp.c @@ -2035,10 +2041,13 @@ The value is non-nil if there were no errors, nil if errors." ;; emacs-lisp files in the build tree are ;; recompiled). Previously this was accomplished by ;; deleting target-file before writing it. - (if (and byte-native-compiling - (null byte-native-always-write-elc)) - (delete-file tempfile) - (rename-file tempfile target-file t))) + (if byte-native-compiling + (if byte-native-for-bootstrap + ;; Defer elc final renaming. + (setf byte-to-native-output-file + (cons tempfile target-file)) + (delete-file tempfile)) + (rename-file tempfile target-file t))) (or noninteractive byte-native-compiling (message "Wrote %s" target-file))) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index edbc98f190..c13844c70b 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2071,12 +2071,16 @@ Return the compilation unit file name." (defun batch-byte-native-compile-for-bootstrap () "As `batch-byte-compile' but used for booststrap. Always generate elc files too and handle native compiler expected errors." - ;; FIXME remove when dynamic scope support is implemented. - (let ((byte-native-always-write-elc t)) - (condition-case _ - (batch-native-compile) - (native-compiler-error-dyn-func) - (native-compiler-error-empty-byte)))) + (let ((byte-native-for-bootstrap t) + (byte-to-native-output-file nil)) + (unwind-protect + (condition-case _ + (batch-native-compile) + (native-compiler-error-dyn-func) + (native-compiler-error-empty-byte)) + (pcase byte-to-native-output-file + (`(,tempfile . ,target-file) + (rename-file tempfile target-file t)))))) ;;;###autoload (defun native-compile-async (input &optional jobs recursively) commit 5153dc17f2393d8fd89d2331b0e9f7ba2d925e87 Merge: 3130690882 b6be1ce644 Author: Andrea Corallo Date: Sun Feb 23 13:42:45 2020 +0000 Merge remote-tracking branch 'savannah/master' into HEAD commit 3130690882d187a5d6b757fd109c60c84009d973 Author: Andrea Corallo Date: Sat Feb 22 10:31:00 2020 +0000 Fix `comp-tests-free-fun' Address the case were comp-tests.el is byte-compiled. diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 00a4022874..e4b7a066cc 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -325,10 +325,11 @@ Check that the resulting binaries do not differ." (ert-deftest comp-tests-free-fun () "Check we are able to compile a single function." - (defun comp-tests-free-fun-f () - "Some doc." - (interactive) - 3) + (eval '(defun comp-tests-free-fun-f () + "Some doc." + (interactive) + 3) + t) (load (native-compile #'comp-tests-free-fun-f)) (should (subr-native-elisp-p (symbol-function #'comp-tests-free-fun-f))) commit 93f86a23784822968ba8f2e1f79abaeb1ab35dab Author: Andrea Corallo Date: Fri Feb 21 18:59:46 2020 +0000 Test 'comp-eq' should not assume any string hashing policy diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index fc6543bcae..00a4022874 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -441,8 +441,7 @@ Check that the resulting binaries do not differ." (ert-deftest comp-eq () (should (comp-test-eq 'a 'a)) (should (comp-test-eq 5 5)) - (should-not (comp-test-eq 'a 'b)) - (should-not (comp-test-eq "x" "x"))) + (should-not (comp-test-eq 'a 'b))) (ert-deftest comp-if () (should (eq (comp-test-if 'a 'b) 'a)) commit 3a7aa06d1575750a498c453bec321a69c2b3bb48 Author: AndreaCorallo Date: Fri Feb 21 14:28:05 2020 +0000 Emit 'top_level_run' objects as impure diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index eabba243c2..edbc98f190 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -99,6 +99,8 @@ Can be used by code that wants to expand differently in this case.") (defvar comp-pass nil "Every pass has the right to bind what it likes here.") +(defvar comp-emitting-impure nil "Non nil to emit only impure objects.") + (defconst comp-passes '(comp-spill-lap comp-limplify comp-ssa @@ -336,14 +338,13 @@ The corresponding index is returned." (push obj (comp-data-container-l cont)) (puthash obj (hash-table-count h) h)))) -(defun comp-add-const-to-relocs (obj &optional impure) +(defun comp-add-const-to-relocs (obj) "Keep track of OBJ into the ctxt relocations. -When IMPURE is non nil OBJ cannot be copied into pure space. The corresponding index is returned." (comp-add-const-to-relocs-to-cont obj - (if impure + (if comp-emitting-impure (comp-ctxt-d-impure comp-ctxt) - (comp-ctxt-d-base comp-ctxt)))) + (comp-ctxt-d-base comp-ctxt)))) (defmacro comp-within-log-buff (&rest body) "Execute BODY while at the end the log-buffer. @@ -526,7 +527,7 @@ Points to the next slot to be filled.") (label-to-addr nil :type hash-table :documentation "LAP hash table -> address.") (pending-blocks () :type list - :documentation "List of blocks waiting for limplification.")) + :documentation "List of blocks waiting for limplification.")) (defconst comp-lap-eob-ops '(byte-goto byte-goto-if-nil byte-goto-if-not-nil byte-goto-if-nil-else-pop @@ -613,12 +614,11 @@ STACK-OFF is the index of the first slot frame involved." for sp from stack-off collect (comp-slot-n sp)))) -(cl-defun make-comp-mvar (&key slot (constant nil const-vld) type - impure) +(cl-defun make-comp-mvar (&key slot (constant nil const-vld) type) (when const-vld - (comp-add-const-to-relocs constant impure)) + (comp-add-const-to-relocs constant)) (make--comp-mvar :slot slot :const-vld const-vld :constant constant - :type type :impure impure)) + :type type :impure comp-emitting-impure)) (defun comp-new-frame (size &optional ssa) "Return a clean frame of meta variables of size SIZE. @@ -1129,7 +1129,8 @@ the annotation emission." (cl-defmethod comp-emit-for-top-level ((form byte-to-native-top-level)) (let ((form (byte-to-native-top-level-form form))) (comp-emit (comp-call 'eval - (make-comp-mvar :constant form :impure t) + (let ((comp-emitting-impure t)) + (make-comp-mvar :constant form)) (make-comp-mvar :constant t))))) (defun comp-limplify-top-level () @@ -1140,7 +1141,11 @@ Synthesize a function called 'top_level_run' that gets one single parameter (the compilation unit it-self). To define native functions 'top_level_run' will call back `comp--register-subr' into the C code forwarding the compilation unit." - (let* ((func (make-comp-func :name 'top-level-run + ;; Once an .eln is loaded and Emacs is dumped 'top_level_run' has no + ;; reasons to be execute ever again. Therefore all objects can be + ;; just impure. + (let* ((comp-emitting-impure t) + (func (make-comp-func :name 'top-level-run :c-name "top_level_run" :args (make-comp-args :min 1 :max 1) :frame-size 1)) commit ec5d95782d90c6b6b7f291a4a8214cc7f64dadd6 Author: Andrea Corallo Date: Fri Feb 21 10:24:32 2020 +0100 Verify '--with-nativecomp' has also '--with-dumping=pdumper' diff --git a/configure.ac b/configure.ac index c8e22ff592..0b2f5b69d6 100644 --- a/configure.ac +++ b/configure.ac @@ -3738,6 +3738,9 @@ If you are sure you want Emacs compiled without elisp native compiler, pass to configure.]) fi fi +if test "${HAVE_NATIVE_COMP}" = yes && test "${HAVE_PDUMPER}" = no; then + AC_MSG_ERROR(['--with-nativecomp' requires '--with-dumping=pdumper']) +fi AC_DEFINE_UNQUOTED(NATIVE_ELISP_SUFFIX, ".eln", [System extension for native compiled elisp]) AC_SUBST(HAVE_NATIVE_COMP) commit d8e4ba2693308b6501f346bb1116daf5ea3a2234 Author: AndreaCorallo Date: Thu Feb 20 09:14:57 2020 +0000 Reorder m-var slots diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 80a542257f..eabba243c2 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -282,18 +282,20 @@ structure.") (cl-defstruct (comp-mvar (:constructor make--comp-mvar)) "A meta-variable being a slot in the meta-stack." - (slot nil :type (or fixnum symbol) - :documentation "Slot number if a number or 'scratch' for scratch slot.") - (array-idx 0 :type fixnum - :documentation "Array index.") (id nil :type (or null number) - :documentation "SSA number when in SSA form.") + :documentation "Unique id when in SSA form.") + ;; The following two are allocation info. + (array-idx 0 :type fixnum + :documentation "The array where the m-var gets allocated.") + (slot nil :type (or fixnum symbol) + :documentation "Slot number in the array if a number or + 'scratch' for scratch slot.") (const-vld nil :type boolean :documentation "Valid signal for the following slot.") (constant nil :documentation "When const-vld non nil this is used for holding a value known at compile time.") - (type nil + (type nil :type symbol :documentation "When non nil indicates the type when known at compile time.") (impure nil :type boolean commit de17b43370fa8549531d34c27d3cbcfb24725c6d Merge: 81c34a35aa 3b4bd4be1d Author: Andrea Corallo Date: Fri Feb 21 15:25:01 2020 +0000 Merge remote-tracking branch 'savannah/master' into HEAD commit 81c34a35aab53978bc2f3608dff3751030d0e914 Author: Andrea Corallo Date: Sun Feb 16 18:14:35 2020 +0100 Update copyright years plus two style nits diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 67fc8f39f8..80a542257f 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2,7 +2,7 @@ ;; Author: Andrea Corallo -;; Copyright (C) 2019 Free Software Foundation, Inc. +;; Copyright (C) 2019-2020 Free Software Foundation, Inc. ;; Keywords: lisp ;; Package: emacs @@ -1587,8 +1587,8 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non nil." ;; Note: this last is just a property of the code generated ;; by the byte-compiler. (cl-assert (= (comp-mvar-array-idx arg) 0)) - (setf (comp-mvar-slot arg) i) - (setf (comp-mvar-array-idx arg) arr-idx)))) + (setf (comp-mvar-slot arg) i + (comp-mvar-array-idx arg) arr-idx)))) (defun comp-propagate-prologue (backward) "Prologue for the propagate pass. @@ -1682,8 +1682,8 @@ Here goes everything that can be done not iteratively (read once). (cl-loop with slot = (comp-mvar-slot lval) for arg in rest do - (setf (comp-mvar-array-idx arg) arr-idx) - (setf (comp-mvar-slot arg) slot))))))) + (setf (comp-mvar-array-idx arg) arr-idx + (comp-mvar-slot arg) slot))))))) (defun comp-propagate* () "Propagate for set* and phi operands. diff --git a/src/comp.c b/src/comp.c index d95a87b03b..2f24b10bba 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1,5 +1,5 @@ /* Compile elisp into native code. - Copyright (C) 2019 Free Software Foundation, Inc. + Copyright (C) 2019-2020 Free Software Foundation, Inc. Author: Andrea Corallo diff --git a/src/comp.h b/src/comp.h index ddebbbcccf..6019831bc3 100644 --- a/src/comp.h +++ b/src/comp.h @@ -1,5 +1,5 @@ /* Elisp native compiler definitions -Copyright (C) 2012-2019 Free Software Foundation, Inc. +Copyright (C) 2019-2020 Free Software Foundation, Inc. This file is part of GNU Emacs. diff --git a/test/src/comp-test-funcs.el b/test/src/comp-test-funcs.el index cbf287838c..46d324bc42 100644 --- a/test/src/comp-test-funcs.el +++ b/test/src/comp-test-funcs.el @@ -1,6 +1,6 @@ ;;; comp-test-funcs.el --- compilation unit tested by comp-tests.el -*- lexical-binding: t; -*- -;; Copyright (C) 2019 Free Software Foundation, Inc. +;; Copyright (C) 2019-2020 Free Software Foundation, Inc. ;; Author: Andrea Corallo diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 15a39c4e88..fc6543bcae 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -1,6 +1,6 @@ ;;; comp-tests.el --- unit tests for src/comp.c -*- lexical-binding: t; -*- -;; Copyright (C) 2019 Free Software Foundation, Inc. +;; Copyright (C) 2019-2020 Free Software Foundation, Inc. ;; Author: Andrea Corallo commit 8c108ce607693f9fb5bfa6ca30da66faad777512 Author: Andrea Corallo Date: Sun Feb 16 12:19:10 2020 +0100 Add a simple pass for self TCO diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 7ba319204d..67fc8f39f8 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -106,6 +106,7 @@ Can be used by code that wants to expand differently in this case.") comp-call-optim comp-propagate-2 comp-dead-code + comp-tco comp-final) "Passes to be executed in order.") @@ -1888,6 +1889,48 @@ These are substituted with a normal 'set' op." (comp-log-func comp-func 3)))) (comp-ctxt-funcs-h comp-ctxt)))) + +;;; Tail Call Optimization pass specific code. + +(defun comp-form-tco-call-seq (args) + "Generate a tco sequence for ARGS." + `(,@(cl-loop for arg in args + for i from 0 + collect `(set ,(make-comp-mvar :slot i) ,arg)) + (jump bb_0))) + +(defun comp-tco-func () + "Try to pattern match and perform TCO within the current function." + (cl-loop + for b being each hash-value of (comp-func-blocks comp-func) + do (cl-loop + named in-the-basic-block + for insns-seq on (comp-block-insns b) + do (pcase insns-seq + (`((set ,l-val (direct-call ,func . ,args)) + (comment ,_comment) + (return ,ret-val)) + (when (and (eq func (comp-func-name comp-func)) + (eq l-val ret-val)) + (let ((tco-seq (comp-form-tco-call-seq args))) + (setf (car insns-seq) (car tco-seq) + (cdr insns-seq) (cdr tco-seq)) + (cl-return-from in-the-basic-block)))))))) + +(defun comp-tco (_) + "Simple peephole pass performing self TCO." + (when (>= comp-speed 3) + (maphash (lambda (_ f) + (let ((comp-func f)) + (unless (comp-func-has-non-local comp-func) + (comp-tco-func) + (comp-log-func comp-func 3)))) + (comp-ctxt-funcs-h comp-ctxt)))) + +;; NOTE: After TCO runs edges, phis etc are not updated. In case some +;; other pass that make use of them after here is added `comp-ssa' +;; should be re-run. + ;;; Final pass specific code. commit 5bd485340fea0788035241860aad0804ebeeb388 Author: Andrea Corallo Date: Sun Feb 16 10:31:46 2020 +0000 Introduce comp-dry-run diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index b6c1a95315..7ba319204d 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -83,6 +83,9 @@ performed at `comp-speed' > 0." :type 'list :group 'comp) +(defvar comp-dry-run nil + "When non nil run everything but the C back-end.") + (defconst comp-log-buffer-name "*Native-compile-Log*" "Name of the native-compiler log buffer.") @@ -1893,7 +1896,8 @@ These are substituted with a normal 'set' op." Prepare every function for final compilation and drive the C back-end." (comp-data-container-check (comp-ctxt-d-base comp-ctxt)) (comp-data-container-check (comp-ctxt-d-impure comp-ctxt)) - (comp--compile-ctxt-to-file name)) + (unless comp-dry-run + (comp--compile-ctxt-to-file name))) (defun comp-final (_) "Final pass driving the C back-end for code emission." commit 2a8a3a9f28a6b1404161512115b059a376bc07f0 Author: Andrea Corallo Date: Sun Feb 16 08:46:30 2020 +0000 Use `sxhash-eq' to generate mvar SSA ids diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 9a782f7497..b6c1a95315 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -271,18 +271,11 @@ structure.") :documentation "Generates block numbers.") (edge-cnt-gen (funcall #'comp-gen-counter) :type function :documentation "Generates edges numbers.") - (ssa-cnt-gen (funcall #'comp-gen-counter) :type function - :documentation "Counter to create ssa limple vars.") (has-non-local nil :type boolean :documentation "t if non local jumps are present.") (array-h (make-hash-table) :type hash-table :documentation "array idx -> array length.")) -(defun comp-func-reset-generators (func) - "Reset unique id generators for FUNC." - (setf (comp-func-edge-cnt-gen func) (comp-gen-counter) - (comp-func-ssa-cnt-gen func) (comp-gen-counter))) - (cl-defstruct (comp-mvar (:constructor make--comp-mvar)) "A meta-variable being a slot in the meta-stack." (slot nil :type (or fixnum symbol) @@ -1254,9 +1247,12 @@ Top-level forms for the current context are rendered too." ;; This pass should be run every time basic blocks or m-var are shuffled. (cl-defun make-comp-ssa-mvar (&key slot (constant nil const-vld) type) - (make--comp-mvar :id (funcall (comp-func-ssa-cnt-gen comp-func)) - :slot slot :const-vld const-vld :constant constant - :type type)) + (let ((mvar (make--comp-mvar :slot slot + :const-vld const-vld + :constant constant + :type type))) + (setf (comp-mvar-id mvar) (sxhash-eq mvar)) + mvar)) (defun comp-compute-edges () "Compute the basic block edges for the current function." @@ -1518,7 +1514,6 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non nil." (let ((comp-func f)) ;; TODO: if this is run more than once we should clean all CFG ;; data including phis here. - (comp-func-reset-generators comp-func) (comp-compute-edges) (comp-compute-dominator-tree) (comp-compute-dominator-frontiers) @@ -1571,7 +1566,6 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non nil." (copy-comp-mvar insn) insn))) - (defun comp-ref-args-to-array (args) "Given ARGS assign them to a dedicated array." (when args commit 4b4c7535a053caf8a074246d0eabb44873119076 Author: AndreaCorallo Date: Fri Feb 14 15:22:24 2020 +0000 Speed 2 goes default diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 6476603f9b..9a782f7497 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -38,7 +38,7 @@ "Emacs Lisp native compiler." :group 'lisp) -(defcustom comp-speed 0 +(defcustom comp-speed 2 "Compiler optimization level. From 0 to 3. - 0 no optimizations are performed, compile time is favored. - 1 lite optimizations. commit 3b3525b916eee975697e9c3c72a5fd780f6eecd6 Author: AndreaCorallo Date: Fri Feb 14 14:54:36 2020 +0000 Backward propagate only once diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 701cba3290..6476603f9b 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -99,9 +99,9 @@ Can be used by code that wants to expand differently in this case.") (defconst comp-passes '(comp-spill-lap comp-limplify comp-ssa - comp-propagate + comp-propagate-1 comp-call-optim - comp-propagate + comp-propagate-2 comp-dead-code comp-final) "Passes to be executed in order.") @@ -1571,11 +1571,10 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non nil." (copy-comp-mvar insn) insn))) + (defun comp-ref-args-to-array (args) "Given ARGS assign them to a dedicated array." - (when (and args - ;; Never rename an already renamed array index. - (= (comp-mvar-array-idx (car args)) 0)) + (when args (cl-loop with array-h = (comp-func-array-h comp-func) with arr-idx = (hash-table-count array-h) for i from 0 @@ -1583,26 +1582,32 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non nil." initially (puthash arr-idx (length args) array-h) do - ;; Just check that all args have zeroed arr-idx. - ;; (arrays must be used once). + ;; We are not supposed to rename arrays more then once. + ;; This because we do only one final back propagation + ;; and arrays are used only once. + + ;; Note: this last is just a property of the code generated + ;; by the byte-compiler. (cl-assert (= (comp-mvar-array-idx arg) 0)) (setf (comp-mvar-slot arg) i) (setf (comp-mvar-array-idx arg) arr-idx)))) -(defun comp-propagate-once () +(defun comp-propagate-prologue (backward) "Prologue for the propagate pass. Here goes everything that can be done not iteratively (read once). -- Forward propagate immediate involed in assignments -- Backward propagate placement into arrays" +- Forward propagate immediate involed in assignments. +- Backward propagate array layout when BACKWARD is non nil." (cl-loop for b being each hash-value of (comp-func-blocks comp-func) do (cl-loop for insn in (comp-block-insns b) do (pcase insn (`(set ,_lval (,(or 'callref 'direct-callref) ,_f . ,args)) - (comp-ref-args-to-array args)) + (when backward + (comp-ref-args-to-array args))) (`(,(or 'callref 'direct-callref) ,_f . ,args) - (comp-ref-args-to-array args)) + (when backward + (comp-ref-args-to-array args))) (`(setimm ,lval ,_ ,v) (setf (comp-mvar-const-vld lval) t (comp-mvar-constant lval) v @@ -1695,13 +1700,13 @@ Return t if something was changed." do (setf modified t)) finally return modified)) -(defun comp-propagate (_) +(defun comp-propagate-iterate (backward) (when (>= comp-speed 2) (maphash (lambda (_ f) ;; FIXME remove the following condition when tested. (unless (comp-func-has-non-local f) (let ((comp-func f)) - (comp-propagate-once) + (comp-propagate-prologue backward) (cl-loop for i from 1 while (comp-propagate*) @@ -1709,6 +1714,15 @@ Return t if something was changed." (comp-log-func comp-func 3)))) (comp-ctxt-funcs-h comp-ctxt)))) +(defun comp-propagate-1 (_) + "Forward propagate types and consts within the lattice." + (comp-propagate-iterate nil)) + +(defun comp-propagate-2 (_) + "Forward propagate types and consts within the lattice. +Backward propagate array placement properties." + (comp-propagate-iterate t)) + ;;; Call optimizer pass specific code. ;; This pass is responsible for the following optimizations: commit c27394da7e3e35ab35e0430ab331d6dadca2803d Author: Andrea Corallo Date: Sun Feb 9 16:17:21 2020 +0100 Rework frame layout Every function call by reference gets use one unique array of arguments. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 2d609f0527..701cba3290 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -274,7 +274,9 @@ structure.") (ssa-cnt-gen (funcall #'comp-gen-counter) :type function :documentation "Counter to create ssa limple vars.") (has-non-local nil :type boolean - :documentation "t if non local jumps are present.")) + :documentation "t if non local jumps are present.") + (array-h (make-hash-table) :type hash-table + :documentation "array idx -> array length.")) (defun comp-func-reset-generators (func) "Reset unique id generators for FUNC." @@ -285,6 +287,8 @@ structure.") "A meta-variable being a slot in the meta-stack." (slot nil :type (or fixnum symbol) :documentation "Slot number if a number or 'scratch' for scratch slot.") + (array-idx 0 :type fixnum + :documentation "Array index.") (id nil :type (or null number) :documentation "SSA number when in SSA form.") (const-vld nil :type boolean @@ -295,9 +299,6 @@ structure.") (type nil :documentation "When non nil indicates the type when known at compile time.") - (ref nil :type boolean - :documentation "When non nil the m-var is involved in a - call where is passed by reference.") (impure nil :type boolean :documentation "When non nil can't be copied into pure space.")) @@ -466,6 +467,8 @@ Put PREFIX in front of it." (comp-byte-frame-size (comp-func-byte-func func)))) (setf (comp-ctxt-top-level-forms comp-ctxt) (list (make-byte-to-native-function :name function-name))) + ;; Create the default array. + (puthash 0 (comp-func-frame-size func) (comp-func-array-h func)) (list func)))) (cl-defgeneric comp-spill-lap-function ((filename string)) @@ -491,7 +494,10 @@ Put PREFIX in front of it." :args (comp-decrypt-arg-list (aref data 0) name) :lap (alist-get name byte-to-native-lap) :frame-size (comp-byte-frame-size data)) - do (comp-log (format "Function %s:\n" name) 1) + do + ;; Create the default array. + (puthash 0 (comp-func-frame-size func) (comp-func-array-h func)) + (comp-log (format "Function %s:\n" name) 1) (comp-log lap 1) collect func)) @@ -1149,6 +1155,7 @@ into the C code forwarding the compilation unit." (comp-emit `(set-par-to-local ,(comp-slot-n 0) 0)) (mapc #'comp-emit-for-top-level (comp-ctxt-top-level-forms comp-ctxt)) (comp-emit `(return ,(make-comp-mvar :constant t))) + (puthash 0 (comp-func-frame-size func) (comp-func-array-h func)) (comp-limplify-finalize-function func))) (defun comp-addr-to-bb-name (addr) @@ -1564,14 +1571,38 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non nil." (copy-comp-mvar insn) insn))) -(defun comp-basic-const-propagate () - "Propagate simple constants for setimm operands. -This can run just once." +(defun comp-ref-args-to-array (args) + "Given ARGS assign them to a dedicated array." + (when (and args + ;; Never rename an already renamed array index. + (= (comp-mvar-array-idx (car args)) 0)) + (cl-loop with array-h = (comp-func-array-h comp-func) + with arr-idx = (hash-table-count array-h) + for i from 0 + for arg in args + initially + (puthash arr-idx (length args) array-h) + do + ;; Just check that all args have zeroed arr-idx. + ;; (arrays must be used once). + (cl-assert (= (comp-mvar-array-idx arg) 0)) + (setf (comp-mvar-slot arg) i) + (setf (comp-mvar-array-idx arg) arr-idx)))) + +(defun comp-propagate-once () + "Prologue for the propagate pass. +Here goes everything that can be done not iteratively (read once). +- Forward propagate immediate involed in assignments +- Backward propagate placement into arrays" (cl-loop for b being each hash-value of (comp-func-blocks comp-func) do (cl-loop for insn in (comp-block-insns b) do (pcase insn + (`(set ,_lval (,(or 'callref 'direct-callref) ,_f . ,args)) + (comp-ref-args-to-array args)) + (`(,(or 'callref 'direct-callref) ,_f . ,args) + (comp-ref-args-to-array args)) (`(setimm ,lval ,_ ,v) (setf (comp-mvar-const-vld lval) t (comp-mvar-constant lval) v @@ -1628,13 +1659,13 @@ This can run just once." (_ (comp-mvar-propagate lval rval)))) (`(phi ,lval . ,rest) - ;; Const prop here. + ;; Forward const prop here. (when-let* ((vld (cl-every #'comp-mvar-const-vld rest)) (consts (mapcar #'comp-mvar-constant rest)) (x (car consts)) (equals (cl-every (lambda (y) (equal x y)) consts))) (setf (comp-mvar-constant lval) x)) - ;; Type propagation. + ;; Forward type propagation. ;; FIXME: checking for type equality is not sufficient cause does not ;; account type hierarchy! (when-let* ((types (mapcar #'comp-mvar-type rest)) @@ -1642,10 +1673,14 @@ This can run just once." (x (car types)) (eqs (cl-every (lambda (y) (eq x y)) types))) (setf (comp-mvar-type lval) x)) - ;; Reference propagation. - (let ((operands (cons lval rest))) - (when (cl-some #'comp-mvar-ref operands) - (mapc (lambda (x) (setf (comp-mvar-ref x) t)) operands)))))) + ;; Backward propagate array index and slot. + (let ((arr-idx (comp-mvar-array-idx lval))) + (when (> arr-idx 0) + (cl-loop with slot = (comp-mvar-slot lval) + for arg in rest + do + (setf (comp-mvar-array-idx arg) arr-idx) + (setf (comp-mvar-slot arg) slot))))))) (defun comp-propagate* () "Propagate for set* and phi operands. @@ -1666,7 +1701,7 @@ Return t if something was changed." ;; FIXME remove the following condition when tested. (unless (comp-func-has-non-local f) (let ((comp-func f)) - (comp-basic-const-propagate) + (comp-propagate-once) (cl-loop for i from 1 while (comp-propagate*) @@ -1695,13 +1730,7 @@ Return t if something was changed." (cl-flet ((fill-args (args total) ;; Fill missing args to reach TOTAL (append args (cl-loop repeat (- total (length args)) - collect (make-comp-mvar :constant nil)))) - (clean-args-ref (args) - ;; Clean-up the ref slot in all args - (mapc (lambda (arg) - (setf (comp-mvar-ref arg) nil)) - args) - args)) + collect (make-comp-mvar :constant nil))))) (when (and (symbolp callee) ; Do nothing if callee is a byte compiled func. (not (memq callee comp-never-optimize-functions))) (let* ((f (symbol-function callee)) @@ -1721,7 +1750,7 @@ Return t if something was changed." (args (if (eq call-type 'callref) args (fill-args args maxarg)))) - `(,call-type ,callee ,@(clean-args-ref args)))) + `(,call-type ,callee ,@args))) ;; Intra compilation unit procedure call optimization. ;; Attention speed 3 triggers that for non self calls too!! ((or (eq callee self) @@ -1733,7 +1762,7 @@ Return t if something was changed." (args (if (eq call-type 'direct-callref) args (fill-args args (comp-args-max func-args))))) - `(,call-type ,callee ,@(clean-args-ref args)))) + `(,call-type ,callee ,@args))) ((comp-type-hint-p callee) `(call ,callee ,@args))))))) diff --git a/src/comp.c b/src/comp.c index 4b1ddeda0f..d95a87b03b 100644 --- a/src/comp.c +++ b/src/comp.c @@ -150,10 +150,10 @@ typedef struct { gcc_jit_field *cast_union_as_lisp_obj_ptr; gcc_jit_function *func; /* Current function being compiled. */ bool func_has_non_local; /* From comp-func has-non-local slot. */ - gcc_jit_block *block; /* Current basic block being compiled. */ - gcc_jit_lvalue **frame; /* Frame for the current function. */ gcc_jit_lvalue **f_frame; /* "Floating" frame for the current function. */ + gcc_jit_block *block; /* Current basic block being compiled. */ gcc_jit_lvalue *scratch; /* Used as scratch slot for some code sequence (switch). */ + gcc_jit_lvalue ***arrays; /* Array index -> gcc_jit_lvalue **. */ gcc_jit_rvalue *most_positive_fixnum; gcc_jit_rvalue *most_negative_fixnum; gcc_jit_rvalue *one; @@ -348,7 +348,7 @@ declare_block (Lisp_Object block_name) } static gcc_jit_lvalue * -get_slot (Lisp_Object mvar) +emit_mvar_access (Lisp_Object mvar) { Lisp_Object mvar_slot = CALL1I (comp-mvar-slot, mvar); @@ -361,15 +361,18 @@ get_slot (Lisp_Object mvar) "scratch"); return comp.scratch; } + + EMACS_INT arr_idx = XFIXNUM (CALL1I (comp-mvar-array-idx, mvar)); EMACS_INT slot_n = XFIXNUM (mvar_slot); - gcc_jit_lvalue **frame = - /* Disable floating frame for functions with non local jumps. - This is probably overkill cause we could do it just for blocks - dominated by push-handler. */ - comp.func_has_non_local - || (CALL1I (comp-mvar-ref, mvar) || SPEED < 2) - ? comp.frame : comp.f_frame; - return frame[slot_n]; + if (comp.func_has_non_local || !SPEED) + return comp.arrays[arr_idx][slot_n]; + else + { + if (arr_idx) + return comp.arrays[arr_idx][slot_n]; + else + return comp.f_frame[slot_n]; + } } static void @@ -1140,7 +1143,7 @@ emit_mvar_val (Lisp_Object mvar) return emit_const_lisp_obj (constant, CALL1I (comp-mvar-impure, mvar)); } - return gcc_jit_lvalue_as_rvalue (get_slot (mvar)); + return gcc_jit_lvalue_as_rvalue (emit_mvar_access (mvar)); } static void @@ -1150,7 +1153,7 @@ emit_frame_assignment (Lisp_Object dst_mvar, gcc_jit_rvalue *val) gcc_jit_block_add_assignment ( comp.block, NULL, - get_slot (dst_mvar), + emit_mvar_access (dst_mvar), val); } @@ -1239,10 +1242,28 @@ emit_limple_call_ref (Lisp_Object insn, bool direct) Lisp_Object callee = FIRST (insn); EMACS_INT nargs = XFIXNUM (Flength (CDR (insn))); - EMACS_INT base_ptr = 0; - if (nargs) - base_ptr = XFIXNUM (CALL1I (comp-mvar-slot, SECOND (insn))); - return emit_call_ref (callee, nargs, comp.frame[base_ptr], direct); + + if (!nargs) + return emit_call_ref (callee, + nargs, + comp.arrays[0][0], + direct); + + Lisp_Object first_arg = SECOND (insn); + Lisp_Object arr_idx = CALL1I (comp-mvar-array-idx, first_arg); + + /* Make sure all the arguments are layout-ed into the same array. */ + Lisp_Object p = XCDR (XCDR (insn)); + FOR_EACH_TAIL (p) + if (!EQ (arr_idx, CALL1I (comp-mvar-array-idx, XCAR (p)))) + xsignal2 (Qnative_ice, build_string ("incoherent array idx for insn"), + insn); + + EMACS_INT first_slot = XFIXNUM (CALL1I (comp-mvar-slot, first_arg)); + return emit_call_ref (callee, + nargs, + comp.arrays[XFIXNUM (arr_idx)][first_slot], + direct); } /* Register an handler for a non local exit. */ @@ -2867,34 +2888,43 @@ compile_function (Lisp_Object func) comp.func_has_non_local = !NILP (CALL1I (comp-func-has-non-local, func)); - gcc_jit_lvalue *frame_array = - gcc_jit_function_new_local ( - comp.func, - NULL, - gcc_jit_context_new_array_type (comp.ctxt, - NULL, - comp.lisp_obj_type, - frame_size), - "local"); - comp.frame = SAFE_ALLOCA (frame_size * sizeof (*comp.frame)); - for (EMACS_INT i = 0; i < frame_size; ++i) - comp.frame[i] = - gcc_jit_context_new_array_access ( - comp.ctxt, - NULL, - gcc_jit_lvalue_as_rvalue (frame_array), - gcc_jit_context_new_rvalue_from_int (comp.ctxt, - comp.int_type, - i)); + struct Lisp_Hash_Table *array_h = + XHASH_TABLE (CALL1I (comp-func-array-h, func)); + comp.arrays = SAFE_ALLOCA (array_h->count * sizeof (*comp.arrays)); + for (ptrdiff_t i = 0; i < array_h->count; i++) + { + EMACS_INT array_len = XFIXNUM (HASH_VALUE (array_h, i)); + comp.arrays[i] = SAFE_ALLOCA (array_len * sizeof (**comp.arrays)); + + gcc_jit_lvalue *arr = + gcc_jit_function_new_local ( + comp.func, + NULL, + gcc_jit_context_new_array_type (comp.ctxt, + NULL, + comp.lisp_obj_type, + array_len), + format_string ("arr_%td", i)); + + for (ptrdiff_t j = 0; j < array_len; j++) + comp.arrays[i][j] = + gcc_jit_context_new_array_access ( + comp.ctxt, + NULL, + gcc_jit_lvalue_as_rvalue (arr), + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.int_type, + j)); + } /* - The floating frame is a copy of the normal frame that can be used to store - locals if the are not going to be used in a nargs call. - This has two advantages: - - Enable gcc for better reordering (frame array is clobbered every time is - passed as parameter being involved into an nargs function call). - - Allow gcc to trigger other optimizations that are prevented by memory - referencing. + The floating frame is a copy of the normal frame that can be used to store + locals if the are not going to be used in a nargs call. + This has two advantages: + - Enable gcc for better reordering (frame array is clobbered every time is + passed as parameter being involved into an nargs function call). + - Allow gcc to trigger other optimizations that are prevented by memory + referencing. */ if (SPEED >= 2) { @@ -2952,7 +2982,6 @@ compile_function (Lisp_Object func) build_string ("failing to compile function"), CALL1I (comp-func-name, func), build_string (err)); - SAFE_FREE (); } commit 0c6f4caeb32b2bf531079feb5a9e73b79496b99d Author: AndreaCorallo Date: Fri Feb 14 14:32:47 2020 +0000 Clean-up old gc disable refuse in comp-tests-non-locals diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index bd844a90c3..15a39c4e88 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -258,16 +258,15 @@ Check that the resulting binaries do not differ." (ert-deftest comp-tests-non-locals () "Test non locals." - (let ((gc-cons-threshold most-positive-fixnum)) ;; FIXME!! - (should (string= (comp-tests-condition-case-0-f) - "arith-error Arithmetic error catched")) - (should (string= (comp-tests-condition-case-1-f) - "error foo catched")) - (should (= (comp-tests-catch-f - (lambda () (throw 'foo 3))) - 3)) - (should (= (catch 'foo - (comp-tests-throw-f 3)))))) + (should (string= (comp-tests-condition-case-0-f) + "arith-error Arithmetic error catched")) + (should (string= (comp-tests-condition-case-1-f) + "error foo catched")) + (should (= (comp-tests-catch-f + (lambda () (throw 'foo 3))) + 3)) + (should (= (catch 'foo + (comp-tests-throw-f 3))))) (ert-deftest comp-tests-gc () "Try to do some longer computation to let the gc kick in." commit fe9e4c42b3e4519032c7c9ee62400f9793ab4f76 Author: Andrea Corallo Date: Sun Feb 9 15:12:51 2020 +0100 Better function naming for comp-function-call-maybe-remove diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 4ec84563f3..2d609f0527 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1599,7 +1599,7 @@ This can run just once." ('/ (and (cl-every #'fixnump values) (not (= (car (last values)) 0))))))))) -(defsubst comp-function-call-remove (insn f args) +(defsubst comp-function-call-maybe-remove (insn f args) "Given INSN when F is pure if all ARGS are known remove the function call." (when (comp-function-optimizable f args) (ignore-errors @@ -1620,13 +1620,11 @@ This can run just once." (`(,(or 'call 'direct-call) ,f . ,args) (setf (comp-mvar-type lval) (alist-get f comp-known-ret-types)) - (comp-function-call-remove insn f args)) + (comp-function-call-maybe-remove insn f args)) (`(,(or 'callref 'direct-callref) ,f . ,args) - (cl-loop for v in args - do (setf (comp-mvar-ref v) t)) (setf (comp-mvar-type lval) (alist-get f comp-known-ret-types)) - (comp-function-call-remove insn f args)) + (comp-function-call-maybe-remove insn f args)) (_ (comp-mvar-propagate lval rval)))) (`(phi ,lval . ,rest) commit f1bc8e480cc9d4a81826b344cac06d0bad88e21e Merge: d71801ea34 333cc6a037 Author: Andrea Corallo Date: Fri Feb 14 23:22:10 2020 +0100 Merge remote-tracking branch 'savannah/master' into HEAD commit d71801ea34b0607edd02d65e2b3150ecd7c2e8fc Author: Andrea Corallo Date: Thu Feb 6 22:57:58 2020 +0100 Clean-up unused variable into load_comp_unit diff --git a/src/comp.c b/src/comp.c index 03b320bf5f..4b1ddeda0f 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3291,7 +3291,6 @@ void load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u, bool loading_dump) { dynlib_handle_ptr handle = comp_u->handle; - Lisp_Object lisp_handle = make_mint_ptr (handle); Lisp_Object comp_u_lisp_obj; XSETNATIVE_COMP_UNIT (comp_u_lisp_obj, comp_u); commit 15aedf3e3d7814aff980098f9290396222c0ff8d Merge: ea56b58098 b641c178ce Author: Andrea Corallo Date: Tue Feb 4 11:40:12 2020 +0000 Merge remote-tracking branch 'savannah/master' into HEAD commit ea56b58098d78b242bc0c51cf1d8b1d21962c130 Author: Andrea Corallo Date: Mon Feb 3 21:12:03 2020 +0000 Add assertion in load_comp_unit While resurrecting from an image dump loading more than once the same compilation unit does not make any sense. diff --git a/src/comp.c b/src/comp.c index ebe7b8b9a9..03b320bf5f 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3300,6 +3300,10 @@ load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u, bool loading_dump) xsignal1 (Qnative_lisp_file_inconsistent, comp_u->file); bool reloading_cu = *saved_cu ? true : false; + /* While resurrecting from an image dump loading more than once the + same compilation unit does not make any sense. */ + eassert (!(loading_dump && reloading_cu)); + if (reloading_cu) /* 'dlopen' returns the same handle when trying to load two times the same shared. In this case touching 'd_reloc' etc leads to commit 7c93bb113ec353baa6316fa97744e65a6e109d91 Author: Andrea Corallo Date: Mon Feb 3 16:40:45 2020 +0000 Rework load mechanism to make Vcomp_loaded_handles unnecessary diff --git a/src/alloc.c b/src/alloc.c index 431238b13e..faa8e70393 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -517,14 +517,6 @@ Lisp_Object const *staticvec[NSTATICS] int staticidx; -/* Lisp of freed native compilation unit handles. - - Because during GC Vcomp_loaded_handles can't be used (hash table) temporary - annotate here and update Vcomp_loaded_handles when finished. -*/ - -static Lisp_Object freed_cu_handles[NATIVE_COMP_FLAG]; - static void *pure_alloc (size_t, int); /* Return PTR rounded up to the next multiple of ALIGNMENT. */ @@ -3038,10 +3030,6 @@ cleanup_vector (struct Lisp_Vector *vector) PSEUDOVEC_STRUCT (vector, Lisp_Native_Comp_Unit); eassert (cu->handle); dynlib_close (cu->handle); - /* We'll update Vcomp_loaded_handles when finished. */ - freed_cu_handles[0] = - Fcons (make_mint_ptr (cu->handle), freed_cu_handles[0]); - set_cons_marked (XCONS (freed_cu_handles[0])); } } @@ -5949,9 +5937,6 @@ garbage_collect (void) if (garbage_collection_messages) message1_nolog ("Garbage collecting..."); - if (NATIVE_COMP_FLAG) - freed_cu_handles[0] = Qnil; - block_input (); shrink_regexp_cache (); @@ -6016,10 +6001,6 @@ garbage_collect (void) gc_in_progress = 0; - if (NATIVE_COMP_FLAG) - FOR_EACH_TAIL (freed_cu_handles[0]) - Fputhash (XCAR (freed_cu_handles[0]), Qnil, Vcomp_loaded_handles); - unblock_input (); consing_until_gc = gc_threshold diff --git a/src/comp.c b/src/comp.c index 7a1ccdcb83..ebe7b8b9a9 100644 --- a/src/comp.c +++ b/src/comp.c @@ -42,6 +42,7 @@ along with GNU Emacs. If not, see . */ #define DATA_RELOC_IMPURE_SYM "d_reloc_imp" #define FUNC_LINK_TABLE_SYM "freloc_link_table" #define LINK_TABLE_HASH_SYM "freloc_hash" +#define COMP_UNIT_SYM "comp_unit" #define TEXT_DATA_RELOC_SYM "text_data_reloc" #define TEXT_DATA_RELOC_IMPURE_SYM "text_data_reloc_imp" @@ -1888,6 +1889,13 @@ emit_ctxt_code (void) gcc_jit_type_get_pointer (comp.void_ptr_type), PURE_RELOC_SYM)); + gcc_jit_context_new_global ( + comp.ctxt, + NULL, + GCC_JIT_GLOBAL_EXPORTED, + gcc_jit_type_get_pointer (comp.lisp_obj_ptr_type), + COMP_UNIT_SYM); + declare_imported_data (); /* Functions imported from Lisp code. */ @@ -3284,9 +3292,13 @@ load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u, bool loading_dump) { dynlib_handle_ptr handle = comp_u->handle; Lisp_Object lisp_handle = make_mint_ptr (handle); - bool reloading_cu = !NILP (Fgethash (lisp_handle, Vcomp_loaded_handles, Qnil)); - Lisp_Object comp_u_obj; - XSETNATIVE_COMP_UNIT (comp_u_obj, comp_u); + Lisp_Object comp_u_lisp_obj; + XSETNATIVE_COMP_UNIT (comp_u_lisp_obj, comp_u); + + Lisp_Object *saved_cu = dynlib_sym (handle, COMP_UNIT_SYM); + if (!saved_cu) + xsignal1 (Qnative_lisp_file_inconsistent, comp_u->file); + bool reloading_cu = *saved_cu ? true : false; if (reloading_cu) /* 'dlopen' returns the same handle when trying to load two times @@ -3297,11 +3309,11 @@ load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u, bool loading_dump) We must *never* mess with static pointers in an already loaded eln. */ { - comp_u_obj = Fgethash (lisp_handle, Vcomp_loaded_handles, Qnil); - comp_u = XNATIVE_COMP_UNIT (comp_u_obj); + comp_u_lisp_obj = *saved_cu; + comp_u = XNATIVE_COMP_UNIT (comp_u_lisp_obj); } else - Fputhash (lisp_handle, comp_u_obj, Vcomp_loaded_handles); + *saved_cu = comp_u_lisp_obj; freloc_check_fill (); @@ -3356,7 +3368,7 @@ load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u, bool loading_dump) if (!loading_dump) /* Executing this will perform all the expected environment modifications. */ - top_level_run (comp_u_obj); + top_level_run (comp_u_lisp_obj); return; } @@ -3538,10 +3550,6 @@ syms_of_comp (void) doc: /* Hash table symbol-function -> function-c-name. For internal use during */); Vcomp_sym_subr_c_name_h = CALLN (Fmake_hash_table); - DEFVAR_LISP ("comp-loaded-handles", Vcomp_loaded_handles, - doc: /* Hash table keeping track of the currently - loaded compilation unit: handle -> comp_u */); - Vcomp_loaded_handles = CALLN (Fmake_hash_table, QCtest, Qequal); } #endif /* HAVE_NATIVE_COMP */ diff --git a/src/pdumper.c b/src/pdumper.c index 8a758499a9..ae8fe014e0 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -5577,7 +5577,6 @@ pdumper_load (const char *dump_filename) dump_hooks[i] (); dump_do_all_dump_reloc_for_phase (header, dump_base, LATE_RELOCS); - Vcomp_loaded_handles = CALLN (Fmake_hash_table, QCtest, Qequal); dump_do_all_dump_reloc_for_phase (header, dump_base, VERY_LATE_RELOCS); initialized = true; commit ffa59bb1611609879151b6dfa94772f9e2144849 Author: Andrea Corallo Date: Sun Feb 2 22:24:03 2020 +0100 Always define subr-native-elisp-p also without native compiler diff --git a/src/data.c b/src/data.c index 8901ffbb2c..b7337b19bc 100644 --- a/src/data.c +++ b/src/data.c @@ -866,7 +866,6 @@ SUBR must be a built-in function. */) return build_string (name); } -#ifdef HAVE_NATIVE_COMP DEFUN ("subr-native-elisp-p", Fsubr_native_elisp_p, Ssubr_native_elisp_p, 1, 1, 0, doc: /* Return t if the object is native compiled lisp function, nil otherwise. */) @@ -875,6 +874,7 @@ nil otherwise. */) return SUBR_NATIVE_COMPILEDP (object) ? Qt : Qnil; } +#ifdef HAVE_NATIVE_COMP DEFUN ("subr-native-comp-unit", Fsubr_native_comp_unit, Ssubr_native_comp_unit, 1, 1, 0, doc: /* Return the native compilation unit. */) commit 6696b561d4d37aebdbb42833d8b5a8d1f4e14482 Author: AndreaCorallo Date: Sun Feb 2 15:39:29 2020 +0000 Fix load_comp_unit for non zero speeds 'dlopen' returns the same handle when trying to load two times the same shared. Touching 'd_reloc' etc leads to fails in case a frame with a reference to it in a register is active. (comp-speed >= 0) diff --git a/src/alloc.c b/src/alloc.c index faa8e70393..431238b13e 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -517,6 +517,14 @@ Lisp_Object const *staticvec[NSTATICS] int staticidx; +/* Lisp of freed native compilation unit handles. + + Because during GC Vcomp_loaded_handles can't be used (hash table) temporary + annotate here and update Vcomp_loaded_handles when finished. +*/ + +static Lisp_Object freed_cu_handles[NATIVE_COMP_FLAG]; + static void *pure_alloc (size_t, int); /* Return PTR rounded up to the next multiple of ALIGNMENT. */ @@ -3030,6 +3038,10 @@ cleanup_vector (struct Lisp_Vector *vector) PSEUDOVEC_STRUCT (vector, Lisp_Native_Comp_Unit); eassert (cu->handle); dynlib_close (cu->handle); + /* We'll update Vcomp_loaded_handles when finished. */ + freed_cu_handles[0] = + Fcons (make_mint_ptr (cu->handle), freed_cu_handles[0]); + set_cons_marked (XCONS (freed_cu_handles[0])); } } @@ -5937,6 +5949,9 @@ garbage_collect (void) if (garbage_collection_messages) message1_nolog ("Garbage collecting..."); + if (NATIVE_COMP_FLAG) + freed_cu_handles[0] = Qnil; + block_input (); shrink_regexp_cache (); @@ -6001,6 +6016,10 @@ garbage_collect (void) gc_in_progress = 0; + if (NATIVE_COMP_FLAG) + FOR_EACH_TAIL (freed_cu_handles[0]) + Fputhash (XCAR (freed_cu_handles[0]), Qnil, Vcomp_loaded_handles); + unblock_input (); consing_until_gc = gc_threshold diff --git a/src/comp.c b/src/comp.c index 290fc3a9c4..7a1ccdcb83 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3282,61 +3282,81 @@ load_static_obj (struct Lisp_Native_Comp_Unit *comp_u, const char *name) void load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u, bool loading_dump) { - freloc_check_fill (); - dynlib_handle_ptr handle = comp_u->handle; - struct thread_state ***current_thread_reloc = - dynlib_sym (handle, CURRENT_THREAD_RELOC_SYM); - EMACS_INT ***pure_reloc = dynlib_sym (handle, PURE_RELOC_SYM); - Lisp_Object *data_relocs = dynlib_sym (handle, DATA_RELOC_SYM); - Lisp_Object *data_imp_relocs = dynlib_sym (handle, DATA_RELOC_IMPURE_SYM); - void **freloc_link_table = dynlib_sym (handle, FUNC_LINK_TABLE_SYM); - void (*top_level_run)(Lisp_Object) = dynlib_sym (handle, "top_level_run"); - - if (!(current_thread_reloc - && pure_reloc - && data_relocs - && data_imp_relocs - && freloc_link_table - && top_level_run) - || NILP (Fstring_equal (load_static_obj (comp_u, LINK_TABLE_HASH_SYM), - hash_subr_list ()))) - xsignal1 (Qnative_lisp_file_inconsistent, comp_u->file); + Lisp_Object lisp_handle = make_mint_ptr (handle); + bool reloading_cu = !NILP (Fgethash (lisp_handle, Vcomp_loaded_handles, Qnil)); + Lisp_Object comp_u_obj; + XSETNATIVE_COMP_UNIT (comp_u_obj, comp_u); + + if (reloading_cu) + /* 'dlopen' returns the same handle when trying to load two times + the same shared. In this case touching 'd_reloc' etc leads to + fails in case a frame with a reference to it in a live reg is + active (comp-speed >= 0). + + We must *never* mess with static pointers in an already loaded + eln. */ + { + comp_u_obj = Fgethash (lisp_handle, Vcomp_loaded_handles, Qnil); + comp_u = XNATIVE_COMP_UNIT (comp_u_obj); + } + else + Fputhash (lisp_handle, comp_u_obj, Vcomp_loaded_handles); - *current_thread_reloc = ¤t_thread; - *pure_reloc = (EMACS_INT **)&pure; + freloc_check_fill (); - /* Imported functions. */ - *freloc_link_table = freloc.link_table; + void (*top_level_run)(Lisp_Object) = dynlib_sym (handle, "top_level_run"); - /* Imported data. */ - if (!loading_dump) + if (!reloading_cu) { - comp_u->data_vec = load_static_obj (comp_u, TEXT_DATA_RELOC_SYM); - comp_u->data_impure_vec = - load_static_obj (comp_u, TEXT_DATA_RELOC_IMPURE_SYM); + struct thread_state ***current_thread_reloc = + dynlib_sym (handle, CURRENT_THREAD_RELOC_SYM); + EMACS_INT ***pure_reloc = dynlib_sym (handle, PURE_RELOC_SYM); + Lisp_Object *data_relocs = dynlib_sym (handle, DATA_RELOC_SYM); + Lisp_Object *data_imp_relocs = dynlib_sym (handle, DATA_RELOC_IMPURE_SYM); + void **freloc_link_table = dynlib_sym (handle, FUNC_LINK_TABLE_SYM); + + if (!(current_thread_reloc + && pure_reloc + && data_relocs + && data_imp_relocs + && freloc_link_table + && top_level_run) + || NILP (Fstring_equal (load_static_obj (comp_u, LINK_TABLE_HASH_SYM), + hash_subr_list ()))) + xsignal1 (Qnative_lisp_file_inconsistent, comp_u->file); + + *current_thread_reloc = ¤t_thread; + *pure_reloc = (EMACS_INT **)&pure; + + /* Imported functions. */ + *freloc_link_table = freloc.link_table; + + /* Imported data. */ + if (!loading_dump) + { + comp_u->data_vec = load_static_obj (comp_u, TEXT_DATA_RELOC_SYM); + comp_u->data_impure_vec = + load_static_obj (comp_u, TEXT_DATA_RELOC_IMPURE_SYM); - if (!NILP (Vpurify_flag)) - /* Non impure can be copied into pure space. */ - comp_u->data_vec = Fpurecopy (comp_u->data_vec); - } + if (!NILP (Vpurify_flag)) + /* Non impure can be copied into pure space. */ + comp_u->data_vec = Fpurecopy (comp_u->data_vec); + } - EMACS_INT d_vec_len = XFIXNUM (Flength (comp_u->data_vec)); - for (EMACS_INT i = 0; i < d_vec_len; i++) - data_relocs[i] = AREF (comp_u->data_vec, i); + EMACS_INT d_vec_len = XFIXNUM (Flength (comp_u->data_vec)); + for (EMACS_INT i = 0; i < d_vec_len; i++) + data_relocs[i] = AREF (comp_u->data_vec, i); - d_vec_len = XFIXNUM (Flength (comp_u->data_impure_vec)); - for (EMACS_INT i = 0; i < d_vec_len; i++) - data_imp_relocs[i] = AREF (comp_u->data_impure_vec, i); + d_vec_len = XFIXNUM (Flength (comp_u->data_impure_vec)); + for (EMACS_INT i = 0; i < d_vec_len; i++) + data_imp_relocs[i] = AREF (comp_u->data_impure_vec, i); + } if (!loading_dump) - { - Lisp_Object comp_u_obj; - XSETNATIVE_COMP_UNIT (comp_u_obj, comp_u); - /* Executing this will perform all the expected environment - modifications. */ - top_level_run (comp_u_obj); - } + /* Executing this will perform all the expected environment + modifications. */ + top_level_run (comp_u_obj); return; } @@ -3518,6 +3538,10 @@ syms_of_comp (void) doc: /* Hash table symbol-function -> function-c-name. For internal use during */); Vcomp_sym_subr_c_name_h = CALLN (Fmake_hash_table); + DEFVAR_LISP ("comp-loaded-handles", Vcomp_loaded_handles, + doc: /* Hash table keeping track of the currently + loaded compilation unit: handle -> comp_u */); + Vcomp_loaded_handles = CALLN (Fmake_hash_table, QCtest, Qequal); } #endif /* HAVE_NATIVE_COMP */ diff --git a/src/pdumper.c b/src/pdumper.c index ae8fe014e0..8a758499a9 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -5577,6 +5577,7 @@ pdumper_load (const char *dump_filename) dump_hooks[i] (); dump_do_all_dump_reloc_for_phase (header, dump_base, LATE_RELOCS); + Vcomp_loaded_handles = CALLN (Fmake_hash_table, QCtest, Qequal); dump_do_all_dump_reloc_for_phase (header, dump_base, VERY_LATE_RELOCS); initialized = true; commit 9e08edf98fdf1a2547eef7b5d9d3debdddb6e7c6 Author: Andrea Corallo Date: Mon Jan 20 21:16:10 2020 +0000 Extend propagation to a wider set of (non pure) functions diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 550fa7ddf2..4ec84563f3 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1529,6 +1529,17 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non nil." ;; This is also responsible for removing function calls to pure functions if ;; possible. +(defvar comp-propagate-classes '(byte-optimize-associative-math + byte-optimize-binary-predicate + byte-optimize-concat + byte-optimize-equal + byte-optimize-identity + byte-optimize-member + byte-optimize-memq + byte-optimize-predicate) + "We optimize functions with 'byte-optimizer' property set to + one of these symbols. See byte-opt.el.") + (defsubst comp-strict-type-of (obj) "Given OBJ return its type understanding fixnums." ;; Should be certainly smarter but now we take advantages just from fixnums. @@ -1572,19 +1583,34 @@ This can run just once." (comp-mvar-constant lval) (comp-mvar-constant rval) (comp-mvar-type lval) (comp-mvar-type rval))) +;; Here should fall most of (defun byte-optimize-* equivalents. +(defsubst comp-function-optimizable (f args) + "Given function F called with ARGS return non nil when optimizable." + (when (cl-every #'comp-mvar-const-vld args) + (or (get f 'pure) + (memq (get f 'byte-optimizer) comp-propagate-classes) + (let ((values (mapcar #'comp-mvar-constant args))) + (pcase f + ;; Simple integer operation. + ;; Note: byte-opt uses `byte-opt--portable-numberp' + ;; instead of just`fixnump'. + ((or '+ '- '* '1+ '-1) (and (cl-every #'fixnump values) + (fixnump (apply f values)))) + ('/ (and (cl-every #'fixnump values) + (not (= (car (last values)) 0))))))))) + (defsubst comp-function-call-remove (insn f args) "Given INSN when F is pure if all ARGS are known remove the function call." - (when (and (get f 'pure) ; Can we just optimize pure here? See byte-opt.el - (cl-every #'comp-mvar-const-vld args)) + (when (comp-function-optimizable f args) (ignore-errors ;; No point to complain here because we should do basic block ;; pruning in order to be sure that this is not dead-code. This ;; is now left to gcc, to be implemented only if we want a ;; reliable diagnostic here. - (let ((val (apply f (mapcar #'comp-mvar-constant args)))) + (let ((values (apply f (mapcar #'comp-mvar-constant args)))) ;; See `comp-emit-set-const'. (setf (car insn) 'setimm - (cddr insn) (list (comp-add-const-to-relocs val) val)))))) + (cddr insn) (list (comp-add-const-to-relocs values) values)))))) (defun comp-propagate-insn (insn) "Propagate within INSN." commit fce1333c22d07c6b359f084b74316458f4187dc4 Author: Andrea Corallo Date: Mon Jan 20 19:30:24 2020 +0000 Clean-up unnecessary member usage diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 69141f657a..550fa7ddf2 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -308,19 +308,19 @@ structure.") (defsubst comp-set-op-p (op) "Assignment predicate for OP." - (when (member op comp-limple-sets) t)) + (when (memq op comp-limple-sets) t)) (defsubst comp-assign-op-p (op) "Assignment predicate for OP." - (when (member op comp-limple-assignments) t)) + (when (memq op comp-limple-assignments) t)) (defsubst comp-limple-insn-call-p (insn) "Limple INSN call predicate." - (when (member (car-safe insn) comp-limple-calls) t)) + (when (memq (car-safe insn) comp-limple-calls) t)) (defsubst comp-type-hint-p (func) "Type hint predicate for function name FUNC." - (when (member func comp-type-hints) t)) + (when (memq func comp-type-hints) t)) (defun comp-data-container-check (cont) "Sanity check CONT coherency." @@ -531,12 +531,12 @@ Points to the next slot to be filled.") (defsubst comp-lap-eob-p (inst) "Return t if INST closes the current basic blocks, nil otherwise." - (when (member (car inst) comp-lap-eob-ops) + (when (memq (car inst) comp-lap-eob-ops) t)) (defsubst comp-lap-fall-through-p (inst) "Return t if INST fall through, nil otherwise." - (when (not (member (car inst) '(byte-goto byte-return))) + (when (not (memq (car inst) '(byte-goto byte-return))) t)) (defsubst comp-sp () @@ -1679,7 +1679,7 @@ Return t if something was changed." args) args)) (when (and (symbolp callee) ; Do nothing if callee is a byte compiled func. - (not (member callee comp-never-optimize-functions))) + (not (memq callee comp-never-optimize-functions))) (let* ((f (symbol-function callee)) (subrp (subrp f)) (callee-in-unit (gethash callee @@ -1788,7 +1788,7 @@ Return the list of m-var ids nuked." for insn = (car insn-cell) for (op arg0 rest) = insn when (and (comp-set-op-p op) - (member (comp-mvar-id arg0) nuke-list)) + (memq (comp-mvar-id arg0) nuke-list)) do (setcar insn-cell (if (comp-limple-insn-call-p rest) rest commit a0c6ee6fc5725dab42aba662d46e46c213c8018a Author: Andrea Corallo Date: Mon Jan 20 21:59:40 2020 +0000 Do no force speed while running the testsuite diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index d71dad6dd5..bd844a90c3 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -29,9 +29,6 @@ (require 'cl-lib) (require 'comp) -;; (setq comp-debug 1) -(setq comp-speed 0) - (defconst comp-test-directory (file-name-directory (or load-file-name buffer-file-name))) (defconst comp-test-src commit e83bc2503b6639542e85a859f88642bde3411bf5 Author: Andrea Corallo Date: Mon Jan 20 21:57:11 2020 +0000 Always force debug 0 for bootstrap test Debug symbols would make it fail otherwise. diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 82a30424d0..d71dad6dd5 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -48,7 +48,9 @@ Check that the resulting binaries do not differ." (comp1-src (make-temp-file "stage1-" nil ".el")) (comp2-src (make-temp-file "stage2-" nil ".el")) (comp1 (concat comp1-src "n")) - (comp2 (concat comp2-src "n"))) + (comp2 (concat comp2-src "n")) + ;; Can't use debug symbols. + (comp-debug 0)) (copy-file comp-src comp1-src t) (copy-file comp-src comp2-src t) (load (concat comp-src "c") nil nil t t) commit c1d034fc27e3aef2370cf0153e7b54dac7eba91b Author: Andrea Corallo Date: Sun Jan 12 11:47:50 2020 +0100 Split relocated data into two separate arrays Rework the functionality of the previous commit to be more efficient. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 0f71746407..69141f657a 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -157,6 +157,13 @@ Can be used by code that wants to expand differently in this case.") finally return h) "Hash table lap-op -> stack adjustment.")) +(cl-defstruct comp-data-container + "Data relocation container structure." + (l () :type list + :documentation "Constant objects used by functions.") + (idx (make-hash-table :test #'equal) :type hash-table + :documentation "Obj -> position into the previous field.")) + (cl-defstruct comp-ctxt "Lisp side of the compiler context." (output nil :type string @@ -166,10 +173,11 @@ Can be used by code that wants to expand differently in this case.") (funcs-h (make-hash-table) :type hash-table :documentation "lisp-func-name -> comp-func. This is to build the prev field.") - (data-relocs-l () :type list - :documentation "List of pairs (impure . obj-to-reloc).") - (data-relocs-idx (make-hash-table :test #'equal) :type hash-table - :documentation "Obj -> position into data-relocs.")) + (d-base (make-comp-data-container) :type comp-data-container + :documentation "Standard data relocated in use by functions.") + (d-impure (make-comp-data-container) :type comp-data-container + :documentation "Data relocated that cannot be moved into pure space. +This is tipically for top-level forms other than defun.")) (cl-defstruct comp-args-base (min nil :type number @@ -314,16 +322,28 @@ structure.") "Type hint predicate for function name FUNC." (when (member func comp-type-hints) t)) +(defun comp-data-container-check (cont) + "Sanity check CONT coherency." + (cl-assert (= (length (comp-data-container-l cont)) + (hash-table-count (comp-data-container-idx cont))))) + +(defun comp-add-const-to-relocs-to-cont (obj cont) + "Keep track of OBJ into the CONT relocation container. +The corresponding index is returned." + (let ((h (comp-data-container-idx cont))) + (if-let ((idx (gethash obj h))) + idx + (push obj (comp-data-container-l cont)) + (puthash obj (hash-table-count h) h)))) + (defun comp-add-const-to-relocs (obj &optional impure) "Keep track of OBJ into the ctxt relocations. When IMPURE is non nil OBJ cannot be copied into pure space. The corresponding index is returned." - (let ((data-relocs-idx (comp-ctxt-data-relocs-idx comp-ctxt)) - (packed-obj (cons impure obj))) - (if-let ((idx (gethash packed-obj data-relocs-idx))) - idx - (push packed-obj (comp-ctxt-data-relocs-l comp-ctxt)) - (puthash packed-obj (hash-table-count data-relocs-idx) data-relocs-idx)))) + (comp-add-const-to-relocs-to-cont obj + (if impure + (comp-ctxt-d-impure comp-ctxt) + (comp-ctxt-d-base comp-ctxt)))) (defmacro comp-within-log-buff (&rest body) "Execute BODY while at the end the log-buffer. @@ -1810,8 +1830,8 @@ These are substituted with a normal 'set' op." (defun comp-compile-ctxt-to-file (name) "Compile as native code the current context naming it NAME. Prepare every function for final compilation and drive the C back-end." - (cl-assert (= (length (comp-ctxt-data-relocs-l comp-ctxt)) - (hash-table-count (comp-ctxt-data-relocs-idx comp-ctxt)))) + (comp-data-container-check (comp-ctxt-d-base comp-ctxt)) + (comp-data-container-check (comp-ctxt-d-impure comp-ctxt)) (comp--compile-ctxt-to-file name)) (defun comp-final (_) diff --git a/src/comp.c b/src/comp.c index 0d1f83eb8f..290fc3a9c4 100644 --- a/src/comp.c +++ b/src/comp.c @@ -39,9 +39,11 @@ along with GNU Emacs. If not, see . */ #define CURRENT_THREAD_RELOC_SYM "current_thread_reloc" #define PURE_RELOC_SYM "pure_reloc" #define DATA_RELOC_SYM "d_reloc" +#define DATA_RELOC_IMPURE_SYM "d_reloc_imp" #define FUNC_LINK_TABLE_SYM "freloc_link_table" #define LINK_TABLE_HASH_SYM "freloc_hash" #define TEXT_DATA_RELOC_SYM "text_data_reloc" +#define TEXT_DATA_RELOC_IMPURE_SYM "text_data_reloc_imp" #define SPEED XFIXNUM (Fsymbol_value (Qcomp_speed)) #define COMP_DEBUG XFIXNUM (Fsymbol_value (Qcomp_debug)) @@ -171,8 +173,12 @@ typedef struct { Lisp_Object exported_funcs_h; /* subr_name -> gcc_jit_function *. */ Lisp_Object imported_funcs_h; /* subr_name -> gcc_jit_field *reloc_field. */ Lisp_Object emitter_dispatcher; - gcc_jit_rvalue *data_relocs; /* Synthesized struct holding data relocs. */ - gcc_jit_lvalue *func_relocs; /* Synthesized struct holding func relocs. */ + /* Synthesized struct holding data relocs. */ + gcc_jit_rvalue *data_relocs; + /* Same as before but can't go in pure space. */ + gcc_jit_rvalue *data_relocs_impure; + /* Synthesized struct holding func relocs. */ + gcc_jit_lvalue *func_relocs; } comp_t; static comp_t comp; @@ -894,9 +900,10 @@ emit_const_lisp_obj (Lisp_Object obj, Lisp_Object impure) comp.void_ptr_type, NULL)); - Lisp_Object d_reloc_idx = CALL1I (comp-ctxt-data-relocs-idx, Vcomp_ctxt); - Lisp_Object packed_obj = Fcons (impure, obj); - Lisp_Object reloc_idx = Fgethash (packed_obj, d_reloc_idx, Qnil); + Lisp_Object container = impure ? CALL1I (comp-ctxt-d-impure, Vcomp_ctxt) + : CALL1I (comp-ctxt-d-base, Vcomp_ctxt); + Lisp_Object reloc_idx = + Fgethash (obj, CALL1I (comp-data-container-idx, container), Qnil); eassert (!NILP (reloc_idx)); gcc_jit_rvalue *reloc_n = gcc_jit_context_new_rvalue_from_int (comp.ctxt, @@ -906,7 +913,8 @@ emit_const_lisp_obj (Lisp_Object obj, Lisp_Object impure) gcc_jit_lvalue_as_rvalue ( gcc_jit_context_new_array_access (comp.ctxt, NULL, - comp.data_relocs, + impure ? comp.data_relocs_impure + : comp.data_relocs, reloc_n)); } @@ -1749,14 +1757,52 @@ emit_static_object (const char *name, Lisp_Object obj) gcc_jit_block_end_with_return (block, NULL, res); } +static gcc_jit_rvalue * +declare_imported_data_relocs (Lisp_Object container, const char *code_symbol, + const char *text_symbol) +{ + /* Imported objects. */ + EMACS_INT d_reloc_len = + XFIXNUM (CALL1I (hash-table-count, + CALL1I (comp-data-container-idx, container))); + Lisp_Object d_reloc = Fnreverse (CALL1I (comp-data-container-l, container)); + d_reloc = Fvconcat (1, &d_reloc); + + gcc_jit_rvalue *reloc_struct = + gcc_jit_lvalue_as_rvalue ( + gcc_jit_context_new_global ( + comp.ctxt, + NULL, + GCC_JIT_GLOBAL_EXPORTED, + gcc_jit_context_new_array_type (comp.ctxt, + NULL, + comp.lisp_obj_type, + d_reloc_len), + code_symbol)); + + emit_static_object (text_symbol, d_reloc); + + return reloc_struct; +} + static void -declare_runtime_imported_data (void) +declare_imported_data (void) { /* Imported symbols by inliner functions. */ CALL1I (comp-add-const-to-relocs, Qnil); CALL1I (comp-add-const-to-relocs, Qt); CALL1I (comp-add-const-to-relocs, Qconsp); CALL1I (comp-add-const-to-relocs, Qlistp); + + /* Imported objects. */ + comp.data_relocs = + declare_imported_data_relocs (CALL1I (comp-ctxt-d-base, Vcomp_ctxt), + DATA_RELOC_SYM, + TEXT_DATA_RELOC_SYM); + comp.data_relocs_impure = + declare_imported_data_relocs (CALL1I (comp-ctxt-d-impure, Vcomp_ctxt), + DATA_RELOC_IMPURE_SYM, + TEXT_DATA_RELOC_IMPURE_SYM); } /* @@ -1842,27 +1888,7 @@ emit_ctxt_code (void) gcc_jit_type_get_pointer (comp.void_ptr_type), PURE_RELOC_SYM)); - declare_runtime_imported_data (); - /* Imported objects. */ - EMACS_INT d_reloc_len = - XFIXNUM (CALL1I (hash-table-count, - CALL1I (comp-ctxt-data-relocs-idx, Vcomp_ctxt))); - Lisp_Object d_reloc = Fnreverse (CALL1I (comp-ctxt-data-relocs-l, Vcomp_ctxt)); - d_reloc = Fvconcat (1, &d_reloc); - - comp.data_relocs = - gcc_jit_lvalue_as_rvalue ( - gcc_jit_context_new_global ( - comp.ctxt, - NULL, - GCC_JIT_GLOBAL_EXPORTED, - gcc_jit_context_new_array_type (comp.ctxt, - NULL, - comp.lisp_obj_type, - d_reloc_len), - DATA_RELOC_SYM)); - - emit_static_object (TEXT_DATA_RELOC_SYM, d_reloc); + declare_imported_data (); /* Functions imported from Lisp code. */ freloc_check_fill (); @@ -3263,12 +3289,14 @@ load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u, bool loading_dump) dynlib_sym (handle, CURRENT_THREAD_RELOC_SYM); EMACS_INT ***pure_reloc = dynlib_sym (handle, PURE_RELOC_SYM); Lisp_Object *data_relocs = dynlib_sym (handle, DATA_RELOC_SYM); + Lisp_Object *data_imp_relocs = dynlib_sym (handle, DATA_RELOC_IMPURE_SYM); void **freloc_link_table = dynlib_sym (handle, FUNC_LINK_TABLE_SYM); void (*top_level_run)(Lisp_Object) = dynlib_sym (handle, "top_level_run"); if (!(current_thread_reloc && pure_reloc && data_relocs + && data_imp_relocs && freloc_link_table && top_level_run) || NILP (Fstring_equal (load_static_obj (comp_u, LINK_TABLE_HASH_SYM), @@ -3283,21 +3311,23 @@ load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u, bool loading_dump) /* Imported data. */ if (!loading_dump) - comp_u->data_vec = load_static_obj (comp_u, TEXT_DATA_RELOC_SYM); + { + comp_u->data_vec = load_static_obj (comp_u, TEXT_DATA_RELOC_SYM); + comp_u->data_impure_vec = + load_static_obj (comp_u, TEXT_DATA_RELOC_IMPURE_SYM); - EMACS_INT d_vec_len = XFIXNUM (Flength (comp_u->data_vec)); + if (!NILP (Vpurify_flag)) + /* Non impure can be copied into pure space. */ + comp_u->data_vec = Fpurecopy (comp_u->data_vec); + } - if (!loading_dump && !NILP (Vpurify_flag)) - for (EMACS_INT i = 0; i < d_vec_len; i++) - { - Lisp_Object packed_obj = AREF (comp_u->data_vec, i); - if (NILP (XCAR (packed_obj))) - /* If is not impure can be copied into pure space. */ - XSETCDR (packed_obj, Fpurecopy (XCDR (packed_obj))); - } + EMACS_INT d_vec_len = XFIXNUM (Flength (comp_u->data_vec)); + for (EMACS_INT i = 0; i < d_vec_len; i++) + data_relocs[i] = AREF (comp_u->data_vec, i); + d_vec_len = XFIXNUM (Flength (comp_u->data_impure_vec)); for (EMACS_INT i = 0; i < d_vec_len; i++) - data_relocs[i] = XCDR (AREF (comp_u->data_vec, i)); + data_imp_relocs[i] = AREF (comp_u->data_impure_vec, i); if (!loading_dump) { diff --git a/src/comp.h b/src/comp.h index 86fa54f515..ddebbbcccf 100644 --- a/src/comp.h +++ b/src/comp.h @@ -38,6 +38,9 @@ struct Lisp_Native_Comp_Unit Lisp_Object file; /* Analogous to the constant vector but per compilation unit. */ Lisp_Object data_vec; + /* Same but for data that cannot be moved to pure space. + Must be the last lisp object here. */ + Lisp_Object data_impure_vec; dynlib_handle_ptr handle; }; diff --git a/src/lisp.h b/src/lisp.h index 2d083dc458..04489959ed 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -4767,8 +4767,8 @@ SUBR_NATIVE_COMPILEDP (Lisp_Object a) INLINE struct Lisp_Native_Comp_Unit * allocate_native_comp_unit (void) { - return ALLOCATE_ZEROED_PSEUDOVECTOR (struct Lisp_Native_Comp_Unit, data_vec, - PVEC_NATIVE_COMP_UNIT); + return ALLOCATE_ZEROED_PSEUDOVECTOR (struct Lisp_Native_Comp_Unit, + data_impure_vec, PVEC_NATIVE_COMP_UNIT); } #else INLINE bool commit 93ed2c32dfd2e385ab0b75e9cbc0768c29b15b50 Author: Andrea Corallo Date: Sat Jan 11 09:50:34 2020 +0100 Move function reloc data into pure space during bootstrap diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 77d47bde8a..0f71746407 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -167,7 +167,7 @@ Can be used by code that wants to expand differently in this case.") :documentation "lisp-func-name -> comp-func. This is to build the prev field.") (data-relocs-l () :type list - :documentation "Constant objects used by functions.") + :documentation "List of pairs (impure . obj-to-reloc).") (data-relocs-idx (make-hash-table :test #'equal) :type hash-table :documentation "Obj -> position into data-relocs.")) @@ -288,8 +288,10 @@ structure.") :documentation "When non nil indicates the type when known at compile time.") (ref nil :type boolean - :documentation "When t the m-var is involved in a call where is passed by - reference.")) + :documentation "When non nil the m-var is involved in a + call where is passed by reference.") + (impure nil :type boolean + :documentation "When non nil can't be copied into pure space.")) ;; Special vars used by some passes (defvar comp-func) @@ -312,14 +314,16 @@ structure.") "Type hint predicate for function name FUNC." (when (member func comp-type-hints) t)) -(defun comp-add-const-to-relocs (obj) +(defun comp-add-const-to-relocs (obj &optional impure) "Keep track of OBJ into the ctxt relocations. +When IMPURE is non nil OBJ cannot be copied into pure space. The corresponding index is returned." - (let ((data-relocs-idx (comp-ctxt-data-relocs-idx comp-ctxt))) - (if-let ((idx (gethash obj data-relocs-idx))) + (let ((data-relocs-idx (comp-ctxt-data-relocs-idx comp-ctxt)) + (packed-obj (cons impure obj))) + (if-let ((idx (gethash packed-obj data-relocs-idx))) idx - (push obj (comp-ctxt-data-relocs-l comp-ctxt)) - (puthash obj (hash-table-count data-relocs-idx) data-relocs-idx)))) + (push packed-obj (comp-ctxt-data-relocs-l comp-ctxt)) + (puthash packed-obj (hash-table-count data-relocs-idx) data-relocs-idx)))) (defmacro comp-within-log-buff (&rest body) "Execute BODY while at the end the log-buffer. @@ -584,11 +588,12 @@ STACK-OFF is the index of the first slot frame involved." for sp from stack-off collect (comp-slot-n sp)))) -(cl-defun make-comp-mvar (&key slot (constant nil const-vld) type) +(cl-defun make-comp-mvar (&key slot (constant nil const-vld) type + impure) (when const-vld - (comp-add-const-to-relocs constant)) + (comp-add-const-to-relocs constant impure)) (make--comp-mvar :slot slot :const-vld const-vld :constant constant - :type type)) + :type type :impure impure)) (defun comp-new-frame (size &optional ssa) "Return a clean frame of meta variables of size SIZE. @@ -1099,7 +1104,7 @@ the annotation emission." (cl-defmethod comp-emit-for-top-level ((form byte-to-native-top-level)) (let ((form (byte-to-native-top-level-form form))) (comp-emit (comp-call 'eval - (make-comp-mvar :constant form) + (make-comp-mvar :constant form :impure t) (make-comp-mvar :constant t))))) (defun comp-limplify-top-level () diff --git a/src/comp.c b/src/comp.c index bb8b952cf5..0d1f83eb8f 100644 --- a/src/comp.c +++ b/src/comp.c @@ -883,7 +883,7 @@ emit_make_fixnum (gcc_jit_rvalue *obj) } static gcc_jit_rvalue * -emit_const_lisp_obj (Lisp_Object obj) +emit_const_lisp_obj (Lisp_Object obj, Lisp_Object impure) { emit_comment (format_string ("const lisp obj: %s", SSDATA (Fprin1_to_string (obj, Qnil)))); @@ -895,11 +895,13 @@ emit_const_lisp_obj (Lisp_Object obj) NULL)); Lisp_Object d_reloc_idx = CALL1I (comp-ctxt-data-relocs-idx, Vcomp_ctxt); - ptrdiff_t reloc_fixn = XFIXNUM (Fgethash (obj, d_reloc_idx, Qnil)); + Lisp_Object packed_obj = Fcons (impure, obj); + Lisp_Object reloc_idx = Fgethash (packed_obj, d_reloc_idx, Qnil); + eassert (!NILP (reloc_idx)); gcc_jit_rvalue *reloc_n = gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.ptrdiff_type, - reloc_fixn); + XFIXNUM (reloc_idx)); return gcc_jit_lvalue_as_rvalue ( gcc_jit_context_new_array_access (comp.ctxt, @@ -912,7 +914,7 @@ static gcc_jit_rvalue * emit_NILP (gcc_jit_rvalue *x) { emit_comment ("NILP"); - return emit_EQ (x, emit_const_lisp_obj (Qnil)); + return emit_EQ (x, emit_const_lisp_obj (Qnil, Qnil)); } static gcc_jit_rvalue * @@ -1015,7 +1017,7 @@ emit_CHECK_CONS (gcc_jit_rvalue *x) gcc_jit_rvalue *args[] = { emit_CONSP (x), - emit_const_lisp_obj (Qconsp), + emit_const_lisp_obj (Qconsp, Qnil), x }; gcc_jit_block_add_eval ( @@ -1126,7 +1128,7 @@ emit_mvar_val (Lisp_Object mvar) return emit_cast (comp.lisp_obj_type, word); } /* Other const objects are fetched from the reloc array. */ - return emit_const_lisp_obj (constant); + return emit_const_lisp_obj (constant, CALL1I (comp-mvar-impure, mvar)); } return gcc_jit_lvalue_as_rvalue (get_slot (mvar)); @@ -1161,7 +1163,7 @@ emit_set_internal (Lisp_Object args) gcc_jit_rvalue *gcc_args[4]; FOR_EACH_TAIL (args) gcc_args[i++] = emit_mvar_val (XCAR (args)); - gcc_args[2] = emit_const_lisp_obj (Qnil); + gcc_args[2] = emit_const_lisp_obj (Qnil, Qnil); gcc_args[3] = gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.int_type, SET_INTERNAL_SET); @@ -2360,11 +2362,11 @@ define_CAR_CDR (void) comp.block = is_nil_b; gcc_jit_block_end_with_return (comp.block, NULL, - emit_const_lisp_obj (Qnil)); + emit_const_lisp_obj (Qnil, Qnil)); comp.block = not_nil_b; gcc_jit_rvalue *wrong_type_args[] = - { emit_const_lisp_obj (Qlistp), c }; + { emit_const_lisp_obj (Qlistp, Qnil), c }; gcc_jit_block_add_eval (comp.block, NULL, @@ -2373,7 +2375,7 @@ define_CAR_CDR (void) false)); gcc_jit_block_end_with_return (comp.block, NULL, - emit_const_lisp_obj (Qnil)); + emit_const_lisp_obj (Qnil, Qnil)); } comp.car = func[0]; comp.cdr = func[1]; @@ -2753,12 +2755,12 @@ define_bool_to_lisp_obj (void) comp.block = ret_t_block; gcc_jit_block_end_with_return (ret_t_block, NULL, - emit_const_lisp_obj (Qt)); + emit_const_lisp_obj (Qt, Qnil)); comp.block = ret_nil_block; gcc_jit_block_end_with_return (ret_nil_block, NULL, - emit_const_lisp_obj (Qnil)); + emit_const_lisp_obj (Qnil, Qnil)); } @@ -3285,8 +3287,17 @@ load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u, bool loading_dump) EMACS_INT d_vec_len = XFIXNUM (Flength (comp_u->data_vec)); + if (!loading_dump && !NILP (Vpurify_flag)) + for (EMACS_INT i = 0; i < d_vec_len; i++) + { + Lisp_Object packed_obj = AREF (comp_u->data_vec, i); + if (NILP (XCAR (packed_obj))) + /* If is not impure can be copied into pure space. */ + XSETCDR (packed_obj, Fpurecopy (XCDR (packed_obj))); + } + for (EMACS_INT i = 0; i < d_vec_len; i++) - data_relocs[i] = AREF (comp_u->data_vec, i); + data_relocs[i] = XCDR (AREF (comp_u->data_vec, i)); if (!loading_dump) { commit a59cc78fcb8df8acbf5139c2b4d2fada55627248 Author: Andrea Corallo Date: Fri Jan 3 02:49:01 2020 +0100 Simplify configure.ac removing unnecessary empty parameters diff --git a/configure.ac b/configure.ac index 717b456499..9c8a6e3a9f 100644 --- a/configure.ac +++ b/configure.ac @@ -3743,7 +3743,7 @@ LIBGCCJIT_LIB= COMP_OBJ= if test "${with_nativecomp}" != "no"; then AC_CHECK_HEADER(libgccjit.h, - AC_CHECK_LIB(gccjit, gcc_jit_context_acquire, HAVE_NATIVE_COMP=yes, , -lgccjit)) + AC_CHECK_LIB(gccjit, gcc_jit_context_acquire, HAVE_NATIVE_COMP=yes)) if test "${HAVE_NATIVE_COMP}" = "yes"; then LIBGCCJIT_LIB="-lgccjit -ldl" COMP_OBJ+=comp.o commit 5a228fefb6f1d1932f452693ded660cd903f457d Author: Andrea Corallo Date: Wed Jan 1 22:02:49 2020 +0100 Prevent false warning emission diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index de3b28e438..77d47bde8a 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1551,15 +1551,15 @@ This can run just once." "Given INSN when F is pure if all ARGS are known remove the function call." (when (and (get f 'pure) ; Can we just optimize pure here? See byte-opt.el (cl-every #'comp-mvar-const-vld args)) - (condition-case err - (let ((val (apply f (mapcar #'comp-mvar-constant args)))) - ;; See `comp-emit-set-const'. - (setf (car insn) 'setimm - (cddr insn) (list (comp-add-const-to-relocs val) val))) - ;; FIXME Should we crash? At least we should complain once. - (t (message "Native compiler trying to move run-time error into \ -compile-time? %S calling %S inside function %S." err f -(comp-func-name comp-func)))))) + (ignore-errors + ;; No point to complain here because we should do basic block + ;; pruning in order to be sure that this is not dead-code. This + ;; is now left to gcc, to be implemented only if we want a + ;; reliable diagnostic here. + (let ((val (apply f (mapcar #'comp-mvar-constant args)))) + ;; See `comp-emit-set-const'. + (setf (car insn) 'setimm + (cddr insn) (list (comp-add-const-to-relocs val) val)))))) (defun comp-propagate-insn (insn) "Propagate within INSN." commit 2239cc81b72e0c066d83271f5c9b4d8097b1ce0d Author: Andrea Corallo Date: Thu Jan 2 22:55:38 2020 +0100 Extend find-library-suffixes and find-library-name for eln support diff --git a/lisp/emacs-lisp/find-func.el b/lisp/emacs-lisp/find-func.el index 167ead3ce0..86b5e5456f 100644 --- a/lisp/emacs-lisp/find-func.el +++ b/lisp/emacs-lisp/find-func.el @@ -167,7 +167,8 @@ See the functions `find-function' and `find-variable'." (defun find-library-suffixes () (let ((suffixes nil)) (dolist (suffix (get-load-suffixes) (nreverse suffixes)) - (unless (string-match "elc" suffix) (push suffix suffixes))))) + (unless (string-match "el[cn]" suffix) + (push suffix suffixes))))) (defun find-library--load-name (library) (let ((name library)) @@ -183,7 +184,7 @@ See the functions `find-function' and `find-variable'." LIBRARY should be a string (the name of the library)." ;; If the library is byte-compiled, try to find a source library by ;; the same name. - (when (string-match "\\.el\\(c\\(\\..*\\)?\\)\\'" library) + (when (string-match "\\.el\\([cn]\\(\\..*\\)?\\)\\'" library) (setq library (replace-match "" t t library))) (or (locate-file library commit 25332bb0d396b79b37e6eaf96850ac560eaa55cd Author: Andrea Corallo Date: Thu Jan 2 22:35:34 2020 +0100 Fix bytecomp message when native compiling diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 19d9884c3f..9278c92d81 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -2035,10 +2035,12 @@ The value is non-nil if there were no errors, nil if errors." ;; recompiled). Previously this was accomplished by ;; deleting target-file before writing it. (if (and byte-native-compiling - (not byte-native-always-write-elc)) + (null byte-native-always-write-elc)) (delete-file tempfile) (rename-file tempfile target-file t))) - (or noninteractive (message "Wrote %s" target-file))) + (or noninteractive + byte-native-compiling + (message "Wrote %s" target-file))) ;; This is just to give a better error message than write-region (let ((exists (file-exists-p target-file))) (signal (if exists 'file-error 'file-missing) commit 3039c55642fbb2feb577e057ee167c2cedc12feb Author: Andrea Corallo Date: Thu Jan 2 22:14:25 2020 +0100 Do not block sw interrupts in batch mode (don't ignore C-c) diff --git a/src/comp.c b/src/comp.c index c25b3245ca..bb8b952cf5 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3110,16 +3110,19 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, gcc_jit_context_set_int_option (comp.ctxt, GCC_JIT_INT_OPTION_OPTIMIZATION_LEVEL, SPEED); - /* Gcc doesn't like being interrupted at all. */ - block_input (); sigset_t oldset; - sigset_t blocked; - sigemptyset (&blocked); - sigaddset (&blocked, SIGALRM); - sigaddset (&blocked, SIGINT); - sigaddset (&blocked, SIGIO); - pthread_sigmask (SIG_BLOCK, &blocked, &oldset); + if (!noninteractive) + { + sigset_t blocked; + /* Gcc doesn't like being interrupted at all. */ + block_input (); + sigemptyset (&blocked); + sigaddset (&blocked, SIGALRM); + sigaddset (&blocked, SIGINT); + sigaddset (&blocked, SIGIO); + pthread_sigmask (SIG_BLOCK, &blocked, &oldset); + } emit_ctxt_code (); /* Define inline functions. */ @@ -3164,8 +3167,11 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, Fdelete_file (out_file, Qnil); Frename_file (tmp_file, out_file, Qnil); - pthread_sigmask (SIG_SETMASK, &oldset, 0); - unblock_input (); + if (!noninteractive) + { + pthread_sigmask (SIG_SETMASK, &oldset, 0); + unblock_input (); + } return out_file; } commit 5252b59b2b3a7959160378cbd0ecb09d9a1da24b Author: Andrea Corallo Date: Thu Jan 2 22:02:20 2020 +0100 Better compile-clean and bootstrap-clean target definition diff --git a/lisp/Makefile.in b/lisp/Makefile.in index 5793b6474d..fdd39d5fd5 100644 --- a/lisp/Makefile.in +++ b/lisp/Makefile.in @@ -365,6 +365,8 @@ compile-clean: if test -f "$$el" || test ! -f "$${el}c"; then :; else \ echo rm "$${el}c"; \ rm "$${el}c"; \ + fi; \ + if test -f "$$el" || test ! -f "$${el}n"; then :; else \ echo rm "$${el}n"; \ rm "$${el}n"; \ fi; \ @@ -485,7 +487,7 @@ $(CAL_DIR)/hol-loaddefs.el: $(CAL_SRC) $(CAL_DIR)/diary-loaddefs.el .PHONY: bootstrap-clean distclean maintainer-clean extraclean bootstrap-clean: - find $(lisp) -name '*.elc' $(FIND_DELETE) + find $(lisp) -regex '.*\.elc\|.*\.eln' $(FIND_DELETE) rm -f $(AUTOGENEL) distclean: commit b0a283872c7bdfb8dbd1af459d0827c07fa72ec2 Author: Andrea Corallo Date: Wed Jan 1 12:14:53 2020 +0100 Revert "Pacify gcc -Wunused-function on Ubuntu 18.04.3" This reverts commit 186152ba400b58d2d278c52d2e3d896decae767e. diff --git a/src/xfns.c b/src/xfns.c index b94666d554..021efafd57 100644 --- a/src/xfns.c +++ b/src/xfns.c @@ -4572,8 +4572,6 @@ On MS Windows, this just returns nil. */) return Qnil; } -#ifndef USE_GTK - /* Store the geometry of the workarea on display DPYINFO into *RECT. Return false if and only if the workarea information cannot be obtained via the _NET_WORKAREA root window property. */ @@ -4636,6 +4634,8 @@ x_get_net_workarea (struct x_display_info *dpyinfo, XRectangle *rect) return result; } +#ifndef USE_GTK + /* Return monitor number where F is "most" or closest to. */ static int x_get_monitor_for_frame (struct frame *f, commit dd66ef5ad198fe914dd603a484e1459dff2af641 Author: Andrea Corallo Date: Wed Jan 1 11:16:59 2020 +0100 set nativecomp configure option off by default diff --git a/configure.ac b/configure.ac index 247484a850..717b456499 100644 --- a/configure.ac +++ b/configure.ac @@ -463,7 +463,7 @@ OPTION_DEFAULT_ON([gnutls],[don't use -lgnutls for SSL/TLS support]) OPTION_DEFAULT_ON([zlib],[don't compile with zlib decompression support]) OPTION_DEFAULT_ON([modules],[compile with dynamic modules support]) OPTION_DEFAULT_ON([threads],[don't compile with elisp threading support]) -OPTION_DEFAULT_ON([nativecomp],[don't compile with emacs lisp native compiler support]) +OPTION_DEFAULT_OFF([nativecomp],[don't 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)])], commit 11192b29adf4ee500f5056d1b02d35908f858b53 Author: Andrea Corallo Date: Wed Jan 1 21:13:13 2020 +0100 make standard emacs compilable again diff --git a/configure.ac b/configure.ac index 8c8b57c107..247484a850 100644 --- a/configure.ac +++ b/configure.ac @@ -3748,8 +3748,6 @@ if test "${with_nativecomp}" != "no"; then LIBGCCJIT_LIB="-lgccjit -ldl" COMP_OBJ+=comp.o AC_DEFINE(HAVE_NATIVE_COMP, 1, [Define to 1 if you have the libgccjit library (-lgccjit).]) - AC_DEFINE_UNQUOTED(NATIVE_ELISP_SUFFIX, ".eln", - [System extension for native compiled elisp]) else AC_MSG_ERROR([elisp native compiler requested but libgccjit not found. If you are sure you want Emacs compiled without elisp native compiler, pass @@ -3757,6 +3755,8 @@ If you are sure you want Emacs compiled without elisp native compiler, pass to configure.]) fi fi +AC_DEFINE_UNQUOTED(NATIVE_ELISP_SUFFIX, ".eln", + [System extension for native compiled elisp]) AC_SUBST(HAVE_NATIVE_COMP) AC_SUBST(LIBGCCJIT_LIB) AC_SUBST(COMP_OBJ) diff --git a/lisp/Makefile.in b/lisp/Makefile.in index cfc6f49499..5793b6474d 100644 --- a/lisp/Makefile.in +++ b/lisp/Makefile.in @@ -332,7 +332,13 @@ compile-first: $(COMPILE_FIRST) .PHONY: compile-targets # TARGETS is set dynamically in the recursive call from 'compile-main'. +# Do not build comp.el unless necessary not to exceed max-specpdl-size and +# max-lisp-eval-depth in normal builds. +ifneq ($(HAVE_NATIVE_COMP),yes) +compile-targets: $(filter-out ./emacs-lisp/comp.elc,$(TARGETS)) +else compile-targets: $(TARGETS) +endif # Compile all the Elisp files that need it. Beware: it approximates # 'no-byte-compile', so watch out for false-positives! diff --git a/src/comp.h b/src/comp.h index 33b7354800..86fa54f515 100644 --- a/src/comp.h +++ b/src/comp.h @@ -29,8 +29,6 @@ enum { #endif }; -#ifdef HAVE_NATIVE_COMP - #include struct Lisp_Native_Comp_Unit @@ -43,6 +41,8 @@ struct Lisp_Native_Comp_Unit dynlib_handle_ptr handle; }; +#ifdef HAVE_NATIVE_COMP + INLINE bool NATIVE_COMP_UNITP (Lisp_Object a) { diff --git a/src/lread.c b/src/lread.c index 1c5268d0da..d6d1386141 100644 --- a/src/lread.c +++ b/src/lread.c @@ -4464,8 +4464,9 @@ defsubr (union Aligned_Lisp_Subr *aname) XSETPVECTYPE (sname, PVEC_SUBR); XSETSUBR (tem, sname); set_symbol_function (sym, tem); - if (NATIVE_COMP_FLAG) - Vcomp_subr_list = Fcons (tem, Vcomp_subr_list); +#ifdef HAVE_NATIVE_COMP + Vcomp_subr_list = Fcons (tem, Vcomp_subr_list); +#endif } #ifdef NOTDEF /* Use fset in subr.el now! */ diff --git a/src/pdumper.c b/src/pdumper.c index 85809c9978..ae8fe014e0 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -5296,6 +5296,7 @@ dump_do_dump_relocation (const uintptr_t dump_base, dump_write_word_to_dump (dump_base, reloc_offset, value); break; } +#ifdef HAVE_NATIVE_COMP case RELOC_NATIVE_COMP_UNIT: { struct Lisp_Native_Comp_Unit *comp_u = @@ -5323,6 +5324,7 @@ dump_do_dump_relocation (const uintptr_t dump_base, subr->function.a0 = func; break; } +#endif case RELOC_BIGNUM: { struct Lisp_Bignum *bignum = dump_ptr (dump_base, reloc_offset); commit 3ba1b52e277261286738b637e45a675b7d587f58 Author: Andrea Corallo Date: Tue Dec 31 03:10:13 2019 +0100 check for libgccjit lib to be reachable in configure.ac diff --git a/configure.ac b/configure.ac index 2afa957254..8c8b57c107 100644 --- a/configure.ac +++ b/configure.ac @@ -3742,14 +3742,11 @@ HAVE_NATIVE_COMP=no LIBGCCJIT_LIB= COMP_OBJ= if test "${with_nativecomp}" != "no"; then - AC_CHECK_HEADER([libgccjit.h], [HAVE_NATIVE_COMP=yes]) + AC_CHECK_HEADER(libgccjit.h, + AC_CHECK_LIB(gccjit, gcc_jit_context_acquire, HAVE_NATIVE_COMP=yes, , -lgccjit)) if test "${HAVE_NATIVE_COMP}" = "yes"; then LIBGCCJIT_LIB="-lgccjit -ldl" - if test "${HAVE_MODULES}" = yes; then - COMP_OBJ="comp.o" - else - COMP_OBJ="dynlib.o comp.o" - fi + COMP_OBJ+=comp.o AC_DEFINE(HAVE_NATIVE_COMP, 1, [Define to 1 if you have the libgccjit library (-lgccjit).]) AC_DEFINE_UNQUOTED(NATIVE_ELISP_SUFFIX, ".eln", [System extension for native compiled elisp]) commit 498468a2367524c7bd763826df5aad2b76345912 Author: Andrea Corallo Date: Tue Dec 31 00:37:47 2019 +0100 make build system configurable again diff --git a/configure.ac b/configure.ac index 03570bd6c9..2afa957254 100644 --- a/configure.ac +++ b/configure.ac @@ -3760,10 +3760,10 @@ If you are sure you want Emacs compiled without elisp native compiler, pass to configure.]) fi fi +AC_SUBST(HAVE_NATIVE_COMP) AC_SUBST(LIBGCCJIT_LIB) AC_SUBST(COMP_OBJ) - ### Use -lpng if available, unless '--with-png=no'. HAVE_PNG=no LIBPNG= diff --git a/lisp/Makefile.in b/lisp/Makefile.in index 5bcb85ff14..cfc6f49499 100644 --- a/lisp/Makefile.in +++ b/lisp/Makefile.in @@ -32,14 +32,15 @@ XARGS_LIMIT = @XARGS_LIMIT@ # 'make' verbosity. AM_DEFAULT_VERBOSITY = @AM_DEFAULT_VERBOSITY@ -AM_V_ELN = $(am__v_ELN_@AM_V@) -am__v_ELN_ = $(am__v_ELN_@AM_DEFAULT_V@) -am__v_ELN_0 = @echo " ELC+ELN " $@; -am__v_ELN_1 = +HAVE_NATIVE_COMP = @HAVE_NATIVE_COMP@ AM_V_ELC = $(am__v_ELC_@AM_V@) am__v_ELC_ = $(am__v_ELC_@AM_DEFAULT_V@) +ifeq ($(HAVE_NATIVE_COMP),yes) am__v_ELC_0 = @echo " ELC+ELN " $@; +else +am__v_ELC_0 = @echo " ELC " $@; +endif am__v_ELC_1 = AM_V_GEN = $(am__v_GEN_@AM_V@) @@ -103,9 +104,11 @@ COMPILE_FIRST = \ $(lisp)/emacs-lisp/macroexp.elc \ $(lisp)/emacs-lisp/cconv.elc \ $(lisp)/emacs-lisp/byte-opt.elc \ - $(lisp)/emacs-lisp/bytecomp.elc \ - $(lisp)/emacs-lisp/autoload.elc \ - $(lisp)/emacs-lisp/comp.elc + $(lisp)/emacs-lisp/bytecomp.elc +ifeq ($(HAVE_NATIVE_COMP),yes) +COMPILE_FIRST += $(lisp)/emacs-lisp/comp.elc +endif +COMPILE_FIRST += $(lisp)/emacs-lisp/autoload.elc # Files to compile early in compile-main. Works around bug#25556. MAIN_FIRST = ./emacs-lisp/eieio.el ./emacs-lisp/eieio-base.el \ @@ -280,19 +283,18 @@ TAGS: ${ETAGS} ${tagsfiles} # src/Makefile.in to rebuild a particular Lisp file, no questions asked. # Use byte-compile-refresh-preloaded to try and work around some of # the most common problems of not bootstrapping from a clean state. -# THEFILE = no-such-file -# .PHONY: $(THEFILE)c -# $(THEFILE)c: -# $(AM_V_ELC)$(emacs) $(BYTE_COMPILE_FLAGS) \ -# -l bytecomp -f byte-compile-refresh-preloaded \ -# -f batch-byte-compile $(THEFILE) - THEFILE = no-such-file .PHONY: $(THEFILE)c $(THEFILE)c: - $(AM_V_ELN)$(emacs) $(BYTE_COMPILE_FLAGS) \ +ifeq ($(HAVE_NATIVE_COMP),yes) + $(AM_V_ELC)$(emacs) $(BYTE_COMPILE_FLAGS) \ -l comp -f byte-compile-refresh-preloaded \ -f batch-byte-native-compile-for-bootstrap $(THEFILE) +else + $(AM_V_ELC)$(emacs) $(BYTE_COMPILE_FLAGS) \ + -l bytecomp -f byte-compile-refresh-preloaded \ + -f batch-byte-compile $(THEFILE) +endif # Files MUST be compiled one by one. If we compile several files in a # row (i.e., in the same instance of Emacs) we can't make sure that @@ -305,12 +307,14 @@ $(THEFILE)c: # An old-fashioned suffix rule, which, according to the GNU Make manual, # cannot have prerequisites. +ifeq ($(HAVE_NATIVE_COMP),yes) .el.elc: $(AM_V_ELC)$(emacs) $(BYTE_COMPILE_FLAGS) \ -l comp -f batch-byte-native-compile-for-bootstrap $< - -.el.eln: - $(AM_V_ELN)$(emacs) $(BYTE_COMPILE_FLAGS) -f batch-native-compile $< +else +.el.elc: + $(AM_V_ELC)$(emacs) $(BYTE_COMPILE_FLAGS) -f batch-byte-compile $< +endif .PHONY: compile-first compile-main compile compile-always diff --git a/src/Makefile.in b/src/Makefile.in index cc43cd9f31..6a151d18d0 100644 --- a/src/Makefile.in +++ b/src/Makefile.in @@ -513,7 +513,6 @@ lisp.mk: $(lispsource)/loadup.el sed -e 's/$$/.elc \\/' -e 's/\.el\.elc/.el/'; \ echo "" ) > $@ - -include lisp.mk shortlisp_filter = leim/leim-list.el site-load.elc site-init.elc shortlisp := $(filter-out ${shortlisp_filter},${shortlisp}) commit c4b886831acb82643a38f48c91456b15363bed75 Author: Andrea Corallo Date: Tue Dec 31 00:19:22 2019 +0100 compile each eln to a temporary one and rename it as last diff --git a/src/comp.c b/src/comp.c index 7d4bcc2cdf..c25b3245ca 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3151,15 +3151,18 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, AUTO_STRING (dot_so, NATIVE_ELISP_SUFFIX); Lisp_Object out_file = CALLN (Fconcat, ctxtname, dot_so); + Lisp_Object tmp_file = + Fmake_temp_file_internal (ctxtname, Qnil, dot_so, Qnil); + gcc_jit_context_compile_to_file (comp.ctxt, + GCC_JIT_OUTPUT_KIND_DYNAMIC_LIBRARY, + SSDATA (tmp_file)); - /* Remove the old eln before creating the new one to get a new inode and - prevent crashes in case the old one is currently loaded. */ + /* Remove the old eln instead of copying the new one into ti to get + a new inode and prevent crashes in case the old one is currently + loaded. */ if (!NILP (Ffile_exists_p (out_file))) Fdelete_file (out_file, Qnil); - - gcc_jit_context_compile_to_file (comp.ctxt, - GCC_JIT_OUTPUT_KIND_DYNAMIC_LIBRARY, - SSDATA (out_file)); + Frename_file (tmp_file, out_file, Qnil); pthread_sigmask (SIG_SETMASK, &oldset, 0); unblock_input (); commit b18f92a942dca6f95c9a74835644e482f3b1b907 Author: Andrea Corallo Date: Tue Dec 31 00:20:35 2019 +0100 rework predicates to be homogeneous diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 039cd6cd41..de3b28e438 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -296,22 +296,21 @@ structure.") -(defun comp-set-op-p (op) +(defsubst comp-set-op-p (op) "Assignment predicate for OP." - (cl-find op comp-limple-sets)) + (when (member op comp-limple-sets) t)) -(defun comp-assign-op-p (op) +(defsubst comp-assign-op-p (op) "Assignment predicate for OP." - (cl-find op comp-limple-assignments)) + (when (member op comp-limple-assignments) t)) -(defun comp-limple-insn-call-p (insn) +(defsubst comp-limple-insn-call-p (insn) "Limple INSN call predicate." - (when (member (car-safe insn) comp-limple-calls) - t)) + (when (member (car-safe insn) comp-limple-calls) t)) -(defun comp-type-hint-p (func) +(defsubst comp-type-hint-p (func) "Type hint predicate for function name FUNC." - (member func comp-type-hints)) + (when (member func comp-type-hints) t)) (defun comp-add-const-to-relocs (obj) "Keep track of OBJ into the ctxt relocations. commit 6c77a9e046de682aaace72aaf3af78e6ba9e5489 Author: Andrea Corallo Date: Sun Dec 29 20:12:17 2019 +0100 do not crash compilation trying to optimize wrong code diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index da1d3f160f..039cd6cd41 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -450,7 +450,8 @@ Put PREFIX in front of it." (byte-compile-file filename) (unless byte-to-native-top-level-forms (signal 'native-compiler-error-empty-byte filename)) - (setf (comp-ctxt-top-level-forms comp-ctxt) (reverse byte-to-native-top-level-forms)) + (setf (comp-ctxt-top-level-forms comp-ctxt) + (reverse byte-to-native-top-level-forms)) (cl-loop for f in (cl-loop for x in byte-to-native-top-level-forms ; All non anonymous. when (and (byte-to-native-function-p x) @@ -1551,10 +1552,15 @@ This can run just once." "Given INSN when F is pure if all ARGS are known remove the function call." (when (and (get f 'pure) ; Can we just optimize pure here? See byte-opt.el (cl-every #'comp-mvar-const-vld args)) - (let ((val (apply f (mapcar #'comp-mvar-constant args)))) - ;; See `comp-emit-set-const'. - (setf (car insn) 'setimm - (cddr insn) (list (comp-add-const-to-relocs val) val))))) + (condition-case err + (let ((val (apply f (mapcar #'comp-mvar-constant args)))) + ;; See `comp-emit-set-const'. + (setf (car insn) 'setimm + (cddr insn) (list (comp-add-const-to-relocs val) val))) + ;; FIXME Should we crash? At least we should complain once. + (t (message "Native compiler trying to move run-time error into \ +compile-time? %S calling %S inside function %S." err f +(comp-func-name comp-func)))))) (defun comp-propagate-insn (insn) "Propagate within INSN." commit 976b7fcc8ced57fa12a0504899974b5b2057c943 Author: Andrea Corallo Date: Sun Dec 29 19:16:53 2019 +0100 fix aliased function names trampoline removal diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index f63e5842bc..da1d3f160f 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1657,7 +1657,8 @@ Return t if something was changed." (cond ((and subrp (not (subr-native-elisp-p f))) ;; Trampoline removal. - (let* ((maxarg (cdr (subr-arity f))) + (let* ((callee (intern (subr-name f))) ; Fix aliased names. + (maxarg (cdr (subr-arity f))) (call-type (if (if subrp (not (numberp maxarg)) (comp-nargs-p callee-in-unit)) commit f0290502f3354f9ed7e8ec84c24ac13a7bad2fc0 Author: Andrea Corallo Date: Sat Dec 28 13:51:46 2019 +0100 disable propagation when non locals are present diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 9272bcc002..f63e5842bc 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1609,13 +1609,15 @@ Return t if something was changed." (defun comp-propagate (_) (when (>= comp-speed 2) (maphash (lambda (_ f) - (let ((comp-func f)) - (comp-basic-const-propagate) - (cl-loop - for i from 1 - while (comp-propagate*) - finally (comp-log (format "Propagation run %d times\n" i) 2)) - (comp-log-func comp-func 3))) + ;; FIXME remove the following condition when tested. + (unless (comp-func-has-non-local f) + (let ((comp-func f)) + (comp-basic-const-propagate) + (cl-loop + for i from 1 + while (comp-propagate*) + finally (comp-log (format "Propagation run %d times\n" i) 2)) + (comp-log-func comp-func 3)))) (comp-ctxt-funcs-h comp-ctxt)))) @@ -1780,13 +1782,15 @@ These are substituted with a normal 'set' op." (when (>= comp-speed 2) (maphash (lambda (_ f) (let ((comp-func f)) - (cl-loop - for i from 1 - while (comp-dead-assignments-func) - finally (comp-log (format "dead code rm run %d times\n" i) 2) - (comp-log-func comp-func 3)) - (comp-remove-type-hints-func) - (comp-log-func comp-func 3))) + ;; FIXME remove the following condition when tested. + (unless (comp-func-has-non-local comp-func) + (cl-loop + for i from 1 + while (comp-dead-assignments-func) + finally (comp-log (format "dead code rm run %d times\n" i) 2) + (comp-log-func comp-func 3)) + (comp-remove-type-hints-func) + (comp-log-func comp-func 3)))) (comp-ctxt-funcs-h comp-ctxt)))) commit 4946ed48fee637eba75b674b9ad568b9df26bac9 Author: Andrea Corallo Date: Sun Dec 29 16:06:07 2019 +0100 rework build system for one pass diff --git a/lisp/Makefile.in b/lisp/Makefile.in index 91b44de46a..5bcb85ff14 100644 --- a/lisp/Makefile.in +++ b/lisp/Makefile.in @@ -34,12 +34,12 @@ AM_DEFAULT_VERBOSITY = @AM_DEFAULT_VERBOSITY@ AM_V_ELN = $(am__v_ELN_@AM_V@) am__v_ELN_ = $(am__v_ELN_@AM_DEFAULT_V@) -am__v_ELN_0 = @echo " ELN " $@; +am__v_ELN_0 = @echo " ELC+ELN " $@; am__v_ELN_1 = AM_V_ELC = $(am__v_ELC_@AM_V@) am__v_ELC_ = $(am__v_ELC_@AM_DEFAULT_V@) -am__v_ELC_0 = @echo " ELC " $@; +am__v_ELC_0 = @echo " ELC+ELN " $@; am__v_ELC_1 = AM_V_GEN = $(am__v_GEN_@AM_V@) @@ -133,7 +133,7 @@ SUBDIRS_SUBDIRS = $(filter-out ${srcdir}/cedet% ${srcdir}/leim%,${SUBDIRS}) # cus-load and finder-inf are not explicitly requested by anything, so # we add them here to make sure they get built. -all: compile-main compile-native-main $(lisp)/cus-load.el $(lisp)/finder-inf.el +all: compile-main $(lisp)/cus-load.el $(lisp)/finder-inf.el PHONY_EXTRAS = .PHONY: all custom-deps finder-data autoloads update-subdirs $(PHONY_EXTRAS) @@ -280,19 +280,19 @@ TAGS: ${ETAGS} ${tagsfiles} # src/Makefile.in to rebuild a particular Lisp file, no questions asked. # Use byte-compile-refresh-preloaded to try and work around some of # the most common problems of not bootstrapping from a clean state. +# THEFILE = no-such-file +# .PHONY: $(THEFILE)c +# $(THEFILE)c: +# $(AM_V_ELC)$(emacs) $(BYTE_COMPILE_FLAGS) \ +# -l bytecomp -f byte-compile-refresh-preloaded \ +# -f batch-byte-compile $(THEFILE) + THEFILE = no-such-file .PHONY: $(THEFILE)c $(THEFILE)c: - $(AM_V_ELC)$(emacs) $(BYTE_COMPILE_FLAGS) \ - -l bytecomp -f byte-compile-refresh-preloaded \ - -f batch-byte-compile $(THEFILE) - -THEFILE = no-such-file -.PHONY: $(THEFILE)n -$(THEFILE)n: $(AM_V_ELN)$(emacs) $(BYTE_COMPILE_FLAGS) \ -l comp -f byte-compile-refresh-preloaded \ - -f batch-native-compile $(THEFILE) + -f batch-byte-native-compile-for-bootstrap $(THEFILE) # Files MUST be compiled one by one. If we compile several files in a # row (i.e., in the same instance of Emacs) we can't make sure that @@ -306,7 +306,8 @@ $(THEFILE)n: # An old-fashioned suffix rule, which, according to the GNU Make manual, # cannot have prerequisites. .el.elc: - $(AM_V_ELC)$(emacs) $(BYTE_COMPILE_FLAGS) -f batch-byte-compile $< + $(AM_V_ELC)$(emacs) $(BYTE_COMPILE_FLAGS) \ + -l comp -f batch-byte-native-compile-for-bootstrap $< .el.eln: $(AM_V_ELN)$(emacs) $(BYTE_COMPILE_FLAGS) -f batch-native-compile $< @@ -345,21 +346,6 @@ compile-main: gen-lisp compile-clean $(MAKE) compile-targets TARGETS="$$chunk"; \ done -# Obsiusly copy pasted from above. Just do it on elns + ignoring errors... -compile-native-main: gen-lisp compile-clean - @(cd $(lisp) && \ - els=`echo "${SUBDIRS_REL} " | sed -e 's|/\./|/|g' -e 's|/\. | |g' -e 's| |/*.el |g'`; \ - for el in ${MAIN_FIRST} $$els; do \ - test -f $$el || continue; \ - test ! -f $${el}c && \ - GREP_OPTIONS= grep '^;.*[^a-zA-Z]no-byte-compile: *t' $$el > /dev/null && \ - continue; \ - echo "$${el}n"; \ - done | xargs $(XARGS_LIMIT) echo) | \ - while read chunk; do \ - $(MAKE) -i compile-targets TARGETS="$$chunk"; \ - done - .PHONY: compile-clean # Erase left-over .elc files that do not have a corresponding .el file. compile-clean: @@ -394,8 +380,6 @@ semantic: # Calling make recursively because suffix rule cannot have prerequisites. compile: $(LOADDEFS) autoloads compile-first $(MAKE) compile-main -# Ignore error for now cause we can't compile dynamic code - $(MAKE) -i compile-native-main # Compile all Lisp files. This is like 'compile' but compiles files # unconditionally. Some files don't actually get compiled because they diff --git a/src/Makefile.in b/src/Makefile.in index faf2480279..cc43cd9f31 100644 --- a/src/Makefile.in +++ b/src/Makefile.in @@ -513,26 +513,15 @@ lisp.mk: $(lispsource)/loadup.el sed -e 's/$$/.elc \\/' -e 's/\.el\.elc/.el/'; \ echo "" ) > $@ -shortnativelisp = -native_lisp.mk: $(lispsource)/loadup.el - @rm -f $@ - ${AM_V_GEN}( printf 'shortnativelisp = \\\n'; \ - sed -n 's/^[ \t]*(load "\([^"]*\)".*/\1/p' $< | \ - sed -e 's/$$/.eln \\/' -e 's/\.el\.eln/.el/'; \ - echo "" ) > $@ -include lisp.mk --include native_lisp.mk shortlisp_filter = leim/leim-list.el site-load.elc site-init.elc shortlisp := $(filter-out ${shortlisp_filter},${shortlisp}) -shortnativelisp_filter = leim/leim-list.el site-load.eln site-init.eln -shortnativelisp := $(filter-out ${shortnativelisp_filter},${shortnativelisp}) ## Place loaddefs.el first, so it gets generated first, since it is on ## the critical path (relevant in parallel compilations). ## We don't really need to sort, but may as well use it to remove duplicates. shortlisp := loaddefs.el loadup.el $(sort ${shortlisp}) lisp = $(addprefix ${lispsource}/,${shortlisp}) -nativelisp = $(addprefix ${lispsource}/,${shortnativelisp}) ## Construct full set of libraries to be linked. LIBES = $(LIBS) $(W32_LIBS) $(LIBS_GNUSTEP) $(LIBX_BASE) $(LIBIMAGE) \ @@ -583,7 +572,7 @@ ${lispintdir}/characters.elc: ${charscript:.el=.elc} ## since not all pieces are used on all platforms. But DOC depends ## on all of $lisp, and emacs depends on DOC, so it is ok to use $lisp here. emacs$(EXEEXT): temacs$(EXEEXT) \ - lisp.mk native_lisp.mk $(etc)/DOC $(lisp) $(nativelisp) \ + lisp.mk $(etc)/DOC $(lisp) \ $(lispsource)/international/charprop.el ${charsets} ifeq ($(DUMPING),unexec) LC_ALL=C $(RUN_TEMACS) -batch $(BUILD_DETAILS) -l loadup --temacs=dump @@ -733,7 +722,7 @@ bootstrap-clean: clean fi distclean: bootstrap-clean - rm -f Makefile lisp.mk native_lisp.mk + rm -f Makefile lisp.mk rm -fr $(DEPDIR) maintainer-clean: distclean @@ -801,7 +790,7 @@ tags: TAGS ../lisp/TAGS $(lwlibdir)/TAGS THEFILE=$< $ Date: Sun Dec 29 22:46:06 2019 +0100 fix nit diff --git a/src/comp.c b/src/comp.c index df841a66fd..7d4bcc2cdf 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3284,7 +3284,7 @@ load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u, bool loading_dump) Lisp_Object comp_u_obj; XSETNATIVE_COMP_UNIT (comp_u_obj, comp_u); /* Executing this will perform all the expected environment - modification. */ + modifications. */ top_level_run (comp_u_obj); } commit 037b9897a464bf25ef9587ee860cc7f20376a97c Author: Andrea Corallo Date: Sun Dec 29 15:56:49 2019 +0100 add batch-byte-native-compile-for-bootstrap diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 3e354951ea..19d9884c3f 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -570,7 +570,9 @@ Each element is (INDEX . VALUE)") "All other top level forms." form) (defvar byte-native-compiling nil - "t while native compiling.") + "Non nil while native compiling.") +(defvar byte-native-always-write-elc nil + "Always write the elc file also while native compiling.") (defvar byte-to-native-lap nil "A-list to accumulate LAP. Each pair is (NAME . LAP)") @@ -2032,7 +2034,8 @@ The value is non-nil if there were no errors, nil if errors." ;; emacs-lisp files in the build tree are ;; recompiled). Previously this was accomplished by ;; deleting target-file before writing it. - (if byte-native-compiling + (if (and byte-native-compiling + (not byte-native-always-write-elc)) (delete-file tempfile) (rename-file tempfile target-file t))) (or noninteractive (message "Wrote %s" target-file))) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 99cc93580b..9272bcc002 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -140,6 +140,13 @@ Can be used by code that wants to expand differently in this case.") direct-callref) "Limple operators use to call subrs.") +(define-error 'native-compiler-error-dyn-func + "can't native compile a non lexical scoped function" + 'native-compiler-error) +(define-error 'native-compiler-error-empty-byte + "empty byte compiler output" + 'native-compiler-error) + (eval-when-compile (defconst comp-op-stack-info (cl-loop with h = (make-hash-table) @@ -390,11 +397,10 @@ Put PREFIX in front of it." (rx (not (any "0-9a-z_"))) "" human-readable))) (concat prefix crypted "_" human-readable))) -(defun comp-decrypt-arg-list (x) - "Decript argument list X." +(defun comp-decrypt-arg-list (x function-name) + "Decript argument list X for FUNCTION-NAME." (unless (fixnump x) - (signal 'native-compiler-error - "can't native compile a non lexical scoped function")) + (signal 'native-compiler-error-dyn-func function-name)) (let ((rest (not (= (logand x 128) 0))) (mandatory (logand x 127)) (nonrest (ash x -8))) @@ -430,7 +436,7 @@ Put PREFIX in front of it." (comp-log lap 2) (let ((arg-list (aref (comp-func-byte-func func) 0))) (setf (comp-func-args func) - (comp-decrypt-arg-list arg-list) + (comp-decrypt-arg-list arg-list function-name) (comp-func-lap func) lap (comp-func-frame-size func) @@ -443,7 +449,7 @@ Put PREFIX in front of it." "Byte compile FILENAME spilling data from the byte compiler." (byte-compile-file filename) (unless byte-to-native-top-level-forms - (signal 'native-compiler-error "empty byte compiler output")) + (signal 'native-compiler-error-empty-byte filename)) (setf (comp-ctxt-top-level-forms comp-ctxt) (reverse byte-to-native-top-level-forms)) (cl-loop for f in (cl-loop for x in byte-to-native-top-level-forms ; All non anonymous. @@ -458,7 +464,7 @@ Put PREFIX in front of it." :doc (documentation data) :int-spec (interactive-form data) :c-name (comp-c-func-name name "F") - :args (comp-decrypt-arg-list (aref data 0)) + :args (comp-decrypt-arg-list (aref data 0) name) :lap (alist-get name byte-to-native-lap) :frame-size (comp-byte-frame-size data)) do (comp-log (format "Function %s:\n" name) 1) @@ -1911,6 +1917,17 @@ Return the compilation unit file name." "Ultra cheap impersonation of `batch-byte-compile'." (mapc #'native-compile command-line-args-left)) +;;;###autoload +(defun batch-byte-native-compile-for-bootstrap () + "As `batch-byte-compile' but used for booststrap. +Always generate elc files too and handle native compiler expected errors." + ;; FIXME remove when dynamic scope support is implemented. + (let ((byte-native-always-write-elc t)) + (condition-case _ + (batch-native-compile) + (native-compiler-error-dyn-func) + (native-compiler-error-empty-byte)))) + ;;;###autoload (defun native-compile-async (input &optional jobs recursively) "Compile INPUT asynchronously. commit e666bf781f1d3d74068e8d2b505e35dd75b5b423 Author: Andrea Corallo Date: Sun Dec 29 14:10:19 2019 +0100 add customize comp-never-optimize-functions diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index b212f24bf9..99cc93580b 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -74,6 +74,15 @@ This intended for debugging the compiler itself. :type 'boolean :group 'comp) +(defcustom comp-never-optimize-functions + '(macroexpand scroll-down scroll-up narrow-to-region widen rename-buffer + make-indirect-buffer delete-file top-level abort-recursive-edit) + "Primitive functions for which we do not perform trampoline optimization. +This is especially usefull for primitives known to be advised if bootstrap is +performed at `comp-speed' > 0." + :type 'list + :group 'comp) + (defconst comp-log-buffer-name "*Native-compile-Log*" "Name of the native-compiler log buffer.") @@ -1631,7 +1640,8 @@ Return t if something was changed." (setf (comp-mvar-ref arg) nil)) args) args)) - (when (symbolp callee) ; Do nothing if callee is a byte compiled func. + (when (and (symbolp callee) ; Do nothing if callee is a byte compiled func. + (not (member callee comp-never-optimize-functions))) (let* ((f (symbol-function callee)) (subrp (subrp f)) (callee-in-unit (gethash callee commit 00f7fd7d427b85e69a53403a1d10ac122a92a95d Author: Andrea Corallo Date: Sat Dec 28 11:39:29 2019 +0100 fix non local propagation handling diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 983ba0e0ba..b212f24bf9 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -248,7 +248,9 @@ structure.") (edge-cnt-gen (funcall #'comp-gen-counter) :type function :documentation "Generates edges numbers.") (ssa-cnt-gen (funcall #'comp-gen-counter) :type function - :documentation "Counter to create ssa limple vars.")) + :documentation "Counter to create ssa limple vars.") + (has-non-local nil :type boolean + :documentation "t if non local jumps are present.")) (defun comp-func-reset-generators (func) "Reset unique id generators for FUNC." @@ -660,6 +662,7 @@ Return value is the fall through block name." "Emit a non local exit handler to LAP-LABEL of type HANDLER-TYPE." (cl-destructuring-bind (label-num . label-sp) lap-label (cl-assert (= (- label-sp 2) (comp-sp))) + (setf (comp-func-has-non-local comp-func) t) (let* ((guarded-bb (comp-bb-maybe-add (1+ (comp-limplify-pc comp-pass)) (comp-sp))) (handler-bb (comp-bb-maybe-add (comp-label-to-addr label-num) @@ -1350,8 +1353,12 @@ Top-level forms for the current context are rendered too." (slot-assigned-p (slot-n bb) ;; Return t if a SLOT-N was assigned within BB. (cl-loop for insn in (comp-block-insns bb) - when (and (comp-assign-op-p (car insn)) - (eql slot-n (comp-mvar-slot (cadr insn)))) + for op = (car insn) + when (or (and (comp-assign-op-p op) + (eql slot-n (comp-mvar-slot (cadr insn)))) + ;; fetch-handler is after a non local + ;; therefore clobbers all frame!!! + (eq op 'fetch-handler)) return t))) (cl-loop for i from 0 below (comp-func-frame-size comp-func) @@ -1411,6 +1418,9 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non nil." (let ((mvar (aref frame slot-n))) (setcdr insn (cl-nsubst-if mvar #'targetp (cdr insn)))) (new-lvalue)) + (`(fetch-handler . ,_) + ;; Clobber all no matter what! + (setf (aref frame slot-n) (make-comp-ssa-mvar :slot slot-n))) (`(phi ,n) (when (equal n slot-n) (new-lvalue))) diff --git a/src/comp.c b/src/comp.c index 5ef0908640..df841a66fd 100644 --- a/src/comp.c +++ b/src/comp.c @@ -146,6 +146,7 @@ typedef struct { gcc_jit_field *cast_union_as_lisp_obj; gcc_jit_field *cast_union_as_lisp_obj_ptr; gcc_jit_function *func; /* Current function being compiled. */ + bool func_has_non_local; /* From comp-func has-non-local slot. */ gcc_jit_block *block; /* Current basic block being compiled. */ gcc_jit_lvalue **frame; /* Frame for the current function. */ gcc_jit_lvalue **f_frame; /* "Floating" frame for the current function. */ @@ -355,7 +356,11 @@ get_slot (Lisp_Object mvar) } EMACS_INT slot_n = XFIXNUM (mvar_slot); gcc_jit_lvalue **frame = - (CALL1I (comp-mvar-ref, mvar) || SPEED < 2) + /* Disable floating frame for functions with non local jumps. + This is probably overkill cause we could do it just for blocks + dominated by push-handler. */ + comp.func_has_non_local + || (CALL1I (comp-mvar-ref, mvar) || SPEED < 2) ? comp.frame : comp.f_frame; return frame[slot_n]; } @@ -2824,6 +2829,8 @@ compile_function (Lisp_Object func) comp.func = xmint_pointer (Fgethash (CALL1I (comp-func-name, func), comp.exported_funcs_h, Qnil)); + comp.func_has_non_local = !NILP (CALL1I (comp-func-has-non-local, func)); + gcc_jit_lvalue *frame_array = gcc_jit_function_new_local ( comp.func, commit 0bb5a47402313634b0e8654355e519388851e07f Author: Andrea Corallo Date: Fri Dec 27 23:02:47 2019 +0100 move LATE_RELOCS just before VERY_LATE_RELOCS diff --git a/src/pdumper.c b/src/pdumper.c index a35cc7ffcd..85809c9978 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -348,10 +348,10 @@ enum reloc_phase { /* First to run. Place here every relocation with no dependecy. */ EARLY_RELOCS, - /* Running after emacs relocations. */ + /* Late and very late relocs are relocated at the very last after + all hooks has been run. All lisp machinery is at disposal + (memory allocation allowed too). */ LATE_RELOCS, - /* Relocated at the very last after all hooks has been run. All - lisp machinery (allocation included) is at disposal. */ VERY_LATE_RELOCS, /* Fake, must be last. */ RELOC_NUM_PHASES @@ -5564,7 +5564,6 @@ pdumper_load (const char *dump_filename) dump_do_all_dump_reloc_for_phase (header, dump_base, EARLY_RELOCS); dump_do_all_emacs_relocations (header, dump_base); - dump_do_all_dump_reloc_for_phase (header, dump_base, LATE_RELOCS); dump_mmap_discard_contents (§ions[DS_DISCARDABLE]); for (int i = 0; i < ARRAYELTS (sections); ++i) @@ -5574,6 +5573,8 @@ pdumper_load (const char *dump_filename) initialization. */ for (int i = 0; i < nr_dump_hooks; ++i) dump_hooks[i] (); + + dump_do_all_dump_reloc_for_phase (header, dump_base, LATE_RELOCS); dump_do_all_dump_reloc_for_phase (header, dump_base, VERY_LATE_RELOCS); initialized = true; commit c00236a880567c72dcdba5fc90d6de1125616c76 Author: Andrea Corallo Date: Fri Dec 27 16:28:44 2019 +0100 sign and check function link table diff --git a/src/comp.c b/src/comp.c index eacda5de55..5ef0908640 100644 --- a/src/comp.c +++ b/src/comp.c @@ -33,12 +33,14 @@ along with GNU Emacs. If not, see . */ #include "dynlib.h" #include "buffer.h" #include "blockinput.h" +#include "sha512.h" /* C symbols emitted for the load relocation mechanism. */ #define CURRENT_THREAD_RELOC_SYM "current_thread_reloc" #define PURE_RELOC_SYM "pure_reloc" #define DATA_RELOC_SYM "d_reloc" #define FUNC_LINK_TABLE_SYM "freloc_link_table" +#define LINK_TABLE_HASH_SYM "freloc_hash" #define TEXT_DATA_RELOC_SYM "text_data_reloc" #define SPEED XFIXNUM (Fsymbol_value (Qcomp_speed)) @@ -225,6 +227,21 @@ format_string (const char *format, ...) return scratch_area; } +/* Produce a key hashing Vcomp_subr_list. */ + +static Lisp_Object +hash_subr_list (void) +{ + Lisp_Object string = Fmapconcat (intern_c_string ("subr-name"), + Vcomp_subr_list, build_string (" ")); + Lisp_Object digest = make_uninit_string (SHA512_DIGEST_SIZE * 2); + + sha512_buffer (SSDATA (string), SCHARS (string), SSDATA (digest)); + hexbuf_digest (SSDATA (digest), SDATA (digest), SHA512_DIGEST_SIZE); + + return digest; +} + static void freloc_check_fill (void) { @@ -1852,6 +1869,9 @@ emit_ctxt_code (void) fields[n_frelocs++] = xmint_pointer (XCDR (el)); } + /* Compute and store function link table hash. */ + emit_static_object (LINK_TABLE_HASH_SYM, hash_subr_list ()); + Lisp_Object subr_l = Vcomp_subr_list; FOR_EACH_TAIL (subr_l) { @@ -3205,10 +3225,12 @@ typedef char *(*comp_lit_str_func) (void); /* Deserialize read and return static object. */ static Lisp_Object -load_static_obj (dynlib_handle_ptr handle, const char *name) +load_static_obj (struct Lisp_Native_Comp_Unit *comp_u, const char *name) { - static_obj_t *(*f)(void) = dynlib_sym (handle, name); - eassert (f); + static_obj_t *(*f)(void) = dynlib_sym (comp_u->handle, name); + if (!f) + xsignal1 (Qnative_lisp_file_inconsistent, comp_u->file); + static_obj_t *res = f (); return Fread (make_string (res->data, res->len)); } @@ -3230,7 +3252,9 @@ load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u, bool loading_dump) && pure_reloc && data_relocs && freloc_link_table - && top_level_run)) + && top_level_run) + || NILP (Fstring_equal (load_static_obj (comp_u, LINK_TABLE_HASH_SYM), + hash_subr_list ()))) xsignal1 (Qnative_lisp_file_inconsistent, comp_u->file); *current_thread_reloc = ¤t_thread; @@ -3241,7 +3265,7 @@ load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u, bool loading_dump) /* Imported data. */ if (!loading_dump) - comp_u->data_vec = load_static_obj (handle, TEXT_DATA_RELOC_SYM); + comp_u->data_vec = load_static_obj (comp_u, TEXT_DATA_RELOC_SYM); EMACS_INT d_vec_len = XFIXNUM (Flength (comp_u->data_vec)); @@ -3408,7 +3432,8 @@ syms_of_comp (void) Fput (Qnative_lisp_file_inconsistent, Qerror_conditions, pure_list (Qnative_lisp_file_inconsistent, Qnative_lisp_load_failed, Qerror)); Fput (Qnative_lisp_file_inconsistent, Qerror_message, - build_pure_c_string ("inconsistent eln file")); + build_pure_c_string ("eln file inconsistent with current runtime " + "configuration, please recompile")); defsubr (&Scomp__init_ctxt); defsubr (&Scomp__release_ctxt); commit 1c08dc82121d50e80bd2dcb0d1f39654cc6762dd Author: Andrea Corallo Date: Fri Dec 27 17:02:23 2019 +0100 some rework to please --enable-check-lisp-object-type diff --git a/src/comp.c b/src/comp.c index 85b0983a6d..eacda5de55 100644 --- a/src/comp.c +++ b/src/comp.c @@ -866,7 +866,7 @@ emit_const_lisp_obj (Lisp_Object obj) emit_comment (format_string ("const lisp obj: %s", SSDATA (Fprin1_to_string (obj, Qnil)))); - if (Qnil == NULL && EQ (obj, Qnil)) + if (NIL_IS_ZERO && EQ (obj, Qnil)) return emit_cast (comp.lisp_obj_type, gcc_jit_context_new_rvalue_from_ptr (comp.ctxt, comp.void_ptr_type, diff --git a/src/data.c b/src/data.c index 191fb31368..8901ffbb2c 100644 --- a/src/data.c +++ b/src/data.c @@ -919,7 +919,7 @@ Value, if non-nil, is a list (interactive SPEC). */) if (SUBRP (fun)) { - if (SUBR_NATIVE_COMPILEDP (fun) && XSUBR (fun)->native_intspec) + if (SUBR_NATIVE_COMPILEDP (fun) && !NILP (XSUBR (fun)->native_intspec)) return XSUBR (fun)->native_intspec; const char *spec = XSUBR (fun)->intspec; diff --git a/src/lisp.h b/src/lisp.h index 69db8cdef1..2d083dc458 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -4761,7 +4761,7 @@ extern char *emacs_root_dir (void); INLINE bool SUBR_NATIVE_COMPILEDP (Lisp_Object a) { - return SUBRP (a) && XSUBR (a)->native_comp_u[0]; + return SUBRP (a) && !NILP (XSUBR (a)->native_comp_u[0]); } INLINE struct Lisp_Native_Comp_Unit * diff --git a/src/pdumper.c b/src/pdumper.c index 81d48496be..a35cc7ffcd 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -2948,13 +2948,13 @@ dump_subr (struct dump_context *ctx, const struct Lisp_Subr *subr) struct Lisp_Subr out; dump_object_start (ctx, &out, sizeof (out)); DUMP_FIELD_COPY (&out, subr, header.size); - if (NATIVE_COMP_FLAG && subr->native_comp_u[0]) + if (NATIVE_COMP_FLAG && !NILP (subr->native_comp_u[0])) out.function.a0 = NULL; else dump_field_emacs_ptr (ctx, &out, subr, &subr->function.a0); DUMP_FIELD_COPY (&out, subr, min_args); DUMP_FIELD_COPY (&out, subr, max_args); - if (NATIVE_COMP_FLAG && subr->native_comp_u[0]) + if (NATIVE_COMP_FLAG && !NILP (subr->native_comp_u[0])) { dump_field_fixup_later (ctx, &out, subr, &subr->symbol_name); dump_remember_cold_op (ctx, @@ -2973,7 +2973,7 @@ dump_subr (struct dump_context *ctx, const struct Lisp_Subr *subr) dump_field_lv (ctx, &out, subr, &subr->native_comp_u[0], WEIGHT_NORMAL); dump_off subr_off = dump_object_finish (ctx, &out, sizeof (out)); - if (ctx->flags.dump_object_contents && subr->native_comp_u[0]) + if (ctx->flags.dump_object_contents && !NILP (subr->native_comp_u[0])) /* We'll do the final addr relocation during VERY_LATE_RELOCS time after the compilation units has been loaded. */ dump_push (&ctx->dump_relocs[VERY_LATE_RELOCS], commit f4cb9cc9034c09a8798df3d98f6fa9313a777a96 Author: Andrea Corallo Date: Fri Dec 27 15:57:31 2019 +0100 rename IMPORTED_FUNC_LINK_TABLE -> FUNC_LINK_TABLE_SYM diff --git a/src/comp.c b/src/comp.c index 98ee6c19a2..85b0983a6d 100644 --- a/src/comp.c +++ b/src/comp.c @@ -38,7 +38,7 @@ along with GNU Emacs. If not, see . */ #define CURRENT_THREAD_RELOC_SYM "current_thread_reloc" #define PURE_RELOC_SYM "pure_reloc" #define DATA_RELOC_SYM "d_reloc" -#define IMPORTED_FUNC_LINK_TABLE "freloc_link_table" +#define FUNC_LINK_TABLE_SYM "freloc_link_table" #define TEXT_DATA_RELOC_SYM "text_data_reloc" #define SPEED XFIXNUM (Fsymbol_value (Qcomp_speed)) @@ -1873,7 +1873,7 @@ emit_ctxt_code (void) NULL, GCC_JIT_GLOBAL_EXPORTED, gcc_jit_type_get_pointer (gcc_jit_struct_as_type (f_reloc_struct)), - IMPORTED_FUNC_LINK_TABLE); + FUNC_LINK_TABLE_SYM); xfree (fields); } @@ -3223,7 +3223,7 @@ load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u, bool loading_dump) dynlib_sym (handle, CURRENT_THREAD_RELOC_SYM); EMACS_INT ***pure_reloc = dynlib_sym (handle, PURE_RELOC_SYM); Lisp_Object *data_relocs = dynlib_sym (handle, DATA_RELOC_SYM); - void **freloc_link_table = dynlib_sym (handle, IMPORTED_FUNC_LINK_TABLE); + void **freloc_link_table = dynlib_sym (handle, FUNC_LINK_TABLE_SYM); void (*top_level_run)(Lisp_Object) = dynlib_sym (handle, "top_level_run"); if (!(current_thread_reloc commit a5a1b53807a9449298f62c761223e6a1c5654bf7 Author: Andrea Corallo Date: Thu Dec 26 20:40:43 2019 +0100 do not force function inlining diff --git a/src/comp.c b/src/comp.c index b081243333..98ee6c19a2 100644 --- a/src/comp.c +++ b/src/comp.c @@ -2239,7 +2239,7 @@ define_CHECK_TYPE (void) "x") }; comp.check_type = gcc_jit_context_new_function (comp.ctxt, NULL, - GCC_JIT_FUNCTION_ALWAYS_INLINE, + GCC_JIT_FUNCTION_INTERNAL, comp.void_type, "CHECK_TYPE", 3, @@ -2613,7 +2613,7 @@ define_PSEUDOVECTORP (void) comp.pseudovectorp = gcc_jit_context_new_function (comp.ctxt, NULL, - GCC_JIT_FUNCTION_ALWAYS_INLINE, + GCC_JIT_FUNCTION_INTERNAL, comp.bool_type, "PSEUDOVECTORP", 2, @@ -2665,7 +2665,7 @@ define_CHECK_IMPURE (void) "ptr") }; comp.check_impure = gcc_jit_context_new_function (comp.ctxt, NULL, - GCC_JIT_FUNCTION_ALWAYS_INLINE, + GCC_JIT_FUNCTION_INTERNAL, comp.void_type, "CHECK_IMPURE", 2, @@ -2709,7 +2709,7 @@ define_bool_to_lisp_obj (void) "x"); comp.bool_to_lisp_obj = gcc_jit_context_new_function (comp.ctxt, NULL, - GCC_JIT_FUNCTION_ALWAYS_INLINE, + GCC_JIT_FUNCTION_INTERNAL, comp.lisp_obj_type, "bool_to_lisp_obj", 1, commit 92e285fdf0821d8a01db598c4e2ac7e2e0fbb3cf Author: Andrea Corallo Date: Thu Dec 26 08:35:01 2019 +0100 set disassemble buffer in read only diff --git a/lisp/emacs-lisp/disass.el b/lisp/emacs-lisp/disass.el index c23dbe1e06..82c8de6e13 100644 --- a/lisp/emacs-lisp/disass.el +++ b/lisp/emacs-lisp/disass.el @@ -103,6 +103,7 @@ redefine OBJECT if it is a symbol." (when (re-search-forward "^.*<.*>:" nil t 2) (delete-region (match-beginning 0) (point-max))) (asm-mode) + (setq buffer-read-only t) (cl-return-from disassemble-internal)) (error "Can't disassemble #" name))) (if (eq (car-safe obj) 'macro) ;Handle macros. commit fdb31d6a2709bff751c2ad240c41b30db1848b44 Author: Andrea Corallo Date: Wed Dec 25 23:04:13 2019 +0100 fix naming for predicate SUBR_NATIVE_COMPILEDP diff --git a/src/alloc.c b/src/alloc.c index 6d6f6934ba..faa8e70393 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -6564,7 +6564,7 @@ mark_object (Lisp_Object arg) break; case PVEC_SUBR: - if (SUBRP_NATIVE_COMPILEDP (obj)) + if (SUBR_NATIVE_COMPILEDP (obj)) { set_vector_marked (ptr); struct Lisp_Subr *subr = XSUBR (obj); @@ -6715,7 +6715,7 @@ survives_gc_p (Lisp_Object obj) case Lisp_Vectorlike: survives_p = - (SUBRP (obj) && !SUBRP_NATIVE_COMPILEDP (obj)) || + (SUBRP (obj) && !SUBR_NATIVE_COMPILEDP (obj)) || vector_marked_p (XVECTOR (obj)); break; diff --git a/src/data.c b/src/data.c index d20db4dc3a..191fb31368 100644 --- a/src/data.c +++ b/src/data.c @@ -872,7 +872,7 @@ DEFUN ("subr-native-elisp-p", Fsubr_native_elisp_p, Ssubr_native_elisp_p, 1, 1, nil otherwise. */) (Lisp_Object object) { - return SUBRP_NATIVE_COMPILEDP (object) ? Qt : Qnil; + return SUBR_NATIVE_COMPILEDP (object) ? Qt : Qnil; } DEFUN ("subr-native-comp-unit", Fsubr_native_comp_unit, @@ -919,7 +919,7 @@ Value, if non-nil, is a list (interactive SPEC). */) if (SUBRP (fun)) { - if (SUBRP_NATIVE_COMPILEDP (fun) && XSUBR (fun)->native_intspec) + if (SUBR_NATIVE_COMPILEDP (fun) && XSUBR (fun)->native_intspec) return XSUBR (fun)->native_intspec; const char *spec = XSUBR (fun)->intspec; diff --git a/src/doc.c b/src/doc.c index 2c96fc15a7..192e201109 100644 --- a/src/doc.c +++ b/src/doc.c @@ -510,7 +510,7 @@ store_function_docstring (Lisp_Object obj, EMACS_INT offset) XSETCAR (tem, make_fixnum (offset)); } } - else if (SUBRP_NATIVE_COMPILEDP (fun)) + else if (SUBR_NATIVE_COMPILEDP (fun)) { XSUBR (fun)->native_doc = Qnil; } diff --git a/src/lisp.h b/src/lisp.h index a4cabc3485..69db8cdef1 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -4759,7 +4759,7 @@ extern char *emacs_root_dir (void); #ifdef HAVE_NATIVE_COMP INLINE bool -SUBRP_NATIVE_COMPILEDP (Lisp_Object a) +SUBR_NATIVE_COMPILEDP (Lisp_Object a) { return SUBRP (a) && XSUBR (a)->native_comp_u[0]; } @@ -4772,7 +4772,7 @@ allocate_native_comp_unit (void) } #else INLINE bool -SUBRP_NATIVE_COMPILEDP (Lisp_Object a) +SUBR_NATIVE_COMPILEDP (Lisp_Object a) { return false; } diff --git a/src/pdumper.c b/src/pdumper.c index 422bec47a6..81d48496be 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -956,7 +956,7 @@ dump_note_reachable (struct dump_context *ctx, Lisp_Object object) static void * dump_object_emacs_ptr (Lisp_Object lv) { - if (SUBRP (lv) && !SUBRP_NATIVE_COMPILEDP (lv)) + if (SUBRP (lv) && !SUBR_NATIVE_COMPILEDP (lv)) return XSUBR (lv); if (dump_builtin_symbol_p (lv)) return XSYMBOL (lv); @@ -3962,7 +3962,7 @@ dump_do_fixup (struct dump_context *ctx, /* Dump wants a pointer to a Lisp object. If DUMP_FIXUP_LISP_OBJECT_RAW, we should stick a C pointer in the dump; otherwise, a Lisp_Object. */ - if (SUBRP (arg) && !SUBRP_NATIVE_COMPILEDP(arg)) + if (SUBRP (arg) && !SUBR_NATIVE_COMPILEDP (arg)) { dump_value = emacs_offset (XSUBR (arg)); if (type == DUMP_FIXUP_LISP_OBJECT) commit 9514dbf7ed70b6c08a11fd58c7889ff49e30ac13 Author: Andrea Corallo Date: Wed Dec 25 20:24:01 2019 +0100 adjust max_specpdl_size to sustain bootstrap diff --git a/src/eval.c b/src/eval.c index 253de05a65..e5c850a579 100644 --- a/src/eval.c +++ b/src/eval.c @@ -227,8 +227,8 @@ init_eval_once (void) else { /* Original values increased for comp.el. */ - max_specpdl_size = 2100; - max_lisp_eval_depth = 1400; + max_specpdl_size = 2500; + max_lisp_eval_depth = 1600; } Vrun_hooks = Qnil; pdumper_do_now_and_after_load (init_eval_once_for_pdumper); commit 4beb850efb99b881fb8b648ad7bb43c6539a2431 Author: Andrea Corallo Date: Tue Dec 24 20:48:49 2019 +0100 add native support to the build system diff --git a/lisp/Makefile.in b/lisp/Makefile.in index 57527bb5af..91b44de46a 100644 --- a/lisp/Makefile.in +++ b/lisp/Makefile.in @@ -32,6 +32,11 @@ XARGS_LIMIT = @XARGS_LIMIT@ # 'make' verbosity. AM_DEFAULT_VERBOSITY = @AM_DEFAULT_VERBOSITY@ +AM_V_ELN = $(am__v_ELN_@AM_V@) +am__v_ELN_ = $(am__v_ELN_@AM_DEFAULT_V@) +am__v_ELN_0 = @echo " ELN " $@; +am__v_ELN_1 = + AM_V_ELC = $(am__v_ELC_@AM_V@) am__v_ELC_ = $(am__v_ELC_@AM_DEFAULT_V@) am__v_ELC_0 = @echo " ELC " $@; @@ -99,7 +104,8 @@ COMPILE_FIRST = \ $(lisp)/emacs-lisp/cconv.elc \ $(lisp)/emacs-lisp/byte-opt.elc \ $(lisp)/emacs-lisp/bytecomp.elc \ - $(lisp)/emacs-lisp/autoload.elc + $(lisp)/emacs-lisp/autoload.elc \ + $(lisp)/emacs-lisp/comp.elc # Files to compile early in compile-main. Works around bug#25556. MAIN_FIRST = ./emacs-lisp/eieio.el ./emacs-lisp/eieio-base.el \ @@ -127,7 +133,7 @@ SUBDIRS_SUBDIRS = $(filter-out ${srcdir}/cedet% ${srcdir}/leim%,${SUBDIRS}) # cus-load and finder-inf are not explicitly requested by anything, so # we add them here to make sure they get built. -all: compile-main $(lisp)/cus-load.el $(lisp)/finder-inf.el +all: compile-main compile-native-main $(lisp)/cus-load.el $(lisp)/finder-inf.el PHONY_EXTRAS = .PHONY: all custom-deps finder-data autoloads update-subdirs $(PHONY_EXTRAS) @@ -281,6 +287,13 @@ $(THEFILE)c: -l bytecomp -f byte-compile-refresh-preloaded \ -f batch-byte-compile $(THEFILE) +THEFILE = no-such-file +.PHONY: $(THEFILE)n +$(THEFILE)n: + $(AM_V_ELN)$(emacs) $(BYTE_COMPILE_FLAGS) \ + -l comp -f byte-compile-refresh-preloaded \ + -f batch-native-compile $(THEFILE) + # Files MUST be compiled one by one. If we compile several files in a # row (i.e., in the same instance of Emacs) we can't make sure that # the compilation environment is clean. We also set the load-path of @@ -288,13 +301,16 @@ $(THEFILE)c: # subdirectories, to make sure require's and load's in the files being # compiled find the right files. -.SUFFIXES: .elc .el +.SUFFIXES: .eln .elc .el # An old-fashioned suffix rule, which, according to the GNU Make manual, # cannot have prerequisites. .el.elc: $(AM_V_ELC)$(emacs) $(BYTE_COMPILE_FLAGS) -f batch-byte-compile $< +.el.eln: + $(AM_V_ELN)$(emacs) $(BYTE_COMPILE_FLAGS) -f batch-native-compile $< + .PHONY: compile-first compile-main compile compile-always compile-first: $(COMPILE_FIRST) @@ -329,6 +345,21 @@ compile-main: gen-lisp compile-clean $(MAKE) compile-targets TARGETS="$$chunk"; \ done +# Obsiusly copy pasted from above. Just do it on elns + ignoring errors... +compile-native-main: gen-lisp compile-clean + @(cd $(lisp) && \ + els=`echo "${SUBDIRS_REL} " | sed -e 's|/\./|/|g' -e 's|/\. | |g' -e 's| |/*.el |g'`; \ + for el in ${MAIN_FIRST} $$els; do \ + test -f $$el || continue; \ + test ! -f $${el}c && \ + GREP_OPTIONS= grep '^;.*[^a-zA-Z]no-byte-compile: *t' $$el > /dev/null && \ + continue; \ + echo "$${el}n"; \ + done | xargs $(XARGS_LIMIT) echo) | \ + while read chunk; do \ + $(MAKE) -i compile-targets TARGETS="$$chunk"; \ + done + .PHONY: compile-clean # Erase left-over .elc files that do not have a corresponding .el file. compile-clean: @@ -338,6 +369,8 @@ compile-clean: if test -f "$$el" || test ! -f "$${el}c"; then :; else \ echo rm "$${el}c"; \ rm "$${el}c"; \ + echo rm "$${el}n"; \ + rm "$${el}n"; \ fi; \ done @@ -361,6 +394,8 @@ semantic: # Calling make recursively because suffix rule cannot have prerequisites. compile: $(LOADDEFS) autoloads compile-first $(MAKE) compile-main +# Ignore error for now cause we can't compile dynamic code + $(MAKE) -i compile-native-main # Compile all Lisp files. This is like 'compile' but compiles files # unconditionally. Some files don't actually get compiled because they diff --git a/lisp/emacs-lisp/autoload.el b/lisp/emacs-lisp/autoload.el index 785e350e0e..53d353858b 100644 --- a/lisp/emacs-lisp/autoload.el +++ b/lisp/emacs-lisp/autoload.el @@ -1045,7 +1045,7 @@ write its autoloads into the specified file instead." ;; we don't want to depend on whether Emacs was ;; built with or without modules support, nor ;; what is the suffix for the underlying OS. - (unless (string-match "\\.\\(elc\\|so\\|dll\\)" suf) + (unless (string-match "\\.\\(elc\\|eln\\|so\\|dll\\)" suf) (push suf tmp))) (concat "^[^=.].*" (regexp-opt tmp t) "\\'"))) (files (apply #'nconc diff --git a/src/Makefile.in b/src/Makefile.in index 6c65275d6d..faf2480279 100644 --- a/src/Makefile.in +++ b/src/Makefile.in @@ -513,14 +513,26 @@ lisp.mk: $(lispsource)/loadup.el sed -e 's/$$/.elc \\/' -e 's/\.el\.elc/.el/'; \ echo "" ) > $@ +shortnativelisp = +native_lisp.mk: $(lispsource)/loadup.el + @rm -f $@ + ${AM_V_GEN}( printf 'shortnativelisp = \\\n'; \ + sed -n 's/^[ \t]*(load "\([^"]*\)".*/\1/p' $< | \ + sed -e 's/$$/.eln \\/' -e 's/\.el\.eln/.el/'; \ + echo "" ) > $@ + -include lisp.mk +-include native_lisp.mk shortlisp_filter = leim/leim-list.el site-load.elc site-init.elc shortlisp := $(filter-out ${shortlisp_filter},${shortlisp}) +shortnativelisp_filter = leim/leim-list.el site-load.eln site-init.eln +shortnativelisp := $(filter-out ${shortnativelisp_filter},${shortnativelisp}) ## Place loaddefs.el first, so it gets generated first, since it is on ## the critical path (relevant in parallel compilations). ## We don't really need to sort, but may as well use it to remove duplicates. shortlisp := loaddefs.el loadup.el $(sort ${shortlisp}) lisp = $(addprefix ${lispsource}/,${shortlisp}) +nativelisp = $(addprefix ${lispsource}/,${shortnativelisp}) ## Construct full set of libraries to be linked. LIBES = $(LIBS) $(W32_LIBS) $(LIBS_GNUSTEP) $(LIBX_BASE) $(LIBIMAGE) \ @@ -571,7 +583,7 @@ ${lispintdir}/characters.elc: ${charscript:.el=.elc} ## since not all pieces are used on all platforms. But DOC depends ## on all of $lisp, and emacs depends on DOC, so it is ok to use $lisp here. emacs$(EXEEXT): temacs$(EXEEXT) \ - lisp.mk $(etc)/DOC $(lisp) \ + lisp.mk native_lisp.mk $(etc)/DOC $(lisp) $(nativelisp) \ $(lispsource)/international/charprop.el ${charsets} ifeq ($(DUMPING),unexec) LC_ALL=C $(RUN_TEMACS) -batch $(BUILD_DETAILS) -l loadup --temacs=dump @@ -721,7 +733,7 @@ bootstrap-clean: clean fi distclean: bootstrap-clean - rm -f Makefile lisp.mk + rm -f Makefile lisp.mk native_lisp.mk rm -fr $(DEPDIR) maintainer-clean: distclean @@ -788,6 +800,10 @@ tags: TAGS ../lisp/TAGS $(lwlibdir)/TAGS @$(MAKE) $(AM_V_NO_PD) -C ../lisp EMACS="$(bootstrap_exe)"\ THEFILE=$< $ Date: Wed Dec 25 18:26:17 2019 +0100 always fill freloc before compiling too diff --git a/src/comp.c b/src/comp.c index 9baa990061..b081243333 100644 --- a/src/comp.c +++ b/src/comp.c @@ -225,6 +225,34 @@ format_string (const char *format, ...) return scratch_area; } +static void +freloc_check_fill (void) +{ + if (freloc.size) + return; + + eassert (!NILP (Vcomp_subr_list)); + + if (ARRAYELTS (helper_link_table) > F_RELOC_MAX_SIZE) + goto overflow; + memcpy (freloc.link_table, helper_link_table, sizeof (helper_link_table)); + freloc.size = ARRAYELTS (helper_link_table); + + Lisp_Object subr_l = Vcomp_subr_list; + FOR_EACH_TAIL (subr_l) + { + if (freloc.size == F_RELOC_MAX_SIZE) + goto overflow; + struct Lisp_Subr *subr = XSUBR (XCAR (subr_l)); + freloc.link_table[freloc.size] = subr->function.a0; + freloc.size++; + } + return; + + overflow: + fatal ("Overflowing function relocation table, increase F_RELOC_MAX_SIZE"); +} + static void bcall0 (Lisp_Object f) { @@ -1813,7 +1841,7 @@ emit_ctxt_code (void) emit_static_object (TEXT_DATA_RELOC_SYM, d_reloc); /* Functions imported from Lisp code. */ - + freloc_check_fill (); gcc_jit_field **fields = xmalloc (freloc.size * sizeof (*fields)); ptrdiff_t n_frelocs = 0; Lisp_Object f_runtime = declare_runtime_imported_funcs (); @@ -3113,34 +3141,6 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, } -static void -freloc_check_fill (void) -{ - if (freloc.size) - return; - - if (ARRAYELTS (helper_link_table) > F_RELOC_MAX_SIZE) - goto overflow; - memcpy (freloc.link_table, helper_link_table, sizeof (helper_link_table)); - freloc.size = ARRAYELTS (helper_link_table); - - eassert (!NILP (Vcomp_subr_list)); - - Lisp_Object subr_l = Vcomp_subr_list; - FOR_EACH_TAIL (subr_l) - { - if (freloc.size == F_RELOC_MAX_SIZE) - goto overflow; - struct Lisp_Subr *subr = XSUBR (XCAR (subr_l)); - freloc.link_table[freloc.size] = subr->function.a0; - freloc.size++; - } - return; - - overflow: - fatal ("Overflowing function relocation table, increase F_RELOC_MAX_SIZE"); -} - /******************************************************************************/ /* Helper functions called from the run-time. */ /* These can't be statics till shared mechanism is used to solve relocations. */ commit 726d8c5bae847a3240b758a1d25135865e9304f0 Author: Andrea Corallo Date: Wed Dec 25 17:07:55 2019 +0100 move late relocs after emacs relocations diff --git a/src/pdumper.c b/src/pdumper.c index d66c4e9964..422bec47a6 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -348,7 +348,7 @@ enum reloc_phase { /* First to run. Place here every relocation with no dependecy. */ EARLY_RELOCS, - /* Run just after EARLY_RELOCS. */ + /* Running after emacs relocations. */ LATE_RELOCS, /* Relocated at the very last after all hooks has been run. All lisp machinery (allocation included) is at disposal. */ @@ -5563,8 +5563,8 @@ pdumper_load (const char *dump_filename) dump_public.end = dump_public.start + dump_size; dump_do_all_dump_reloc_for_phase (header, dump_base, EARLY_RELOCS); - dump_do_all_dump_reloc_for_phase (header, dump_base, LATE_RELOCS); dump_do_all_emacs_relocations (header, dump_base); + dump_do_all_dump_reloc_for_phase (header, dump_base, LATE_RELOCS); dump_mmap_discard_contents (§ions[DS_DISCARDABLE]); for (int i = 0; i < ARRAYELTS (sections); ++i) commit 44db9b912f1d8165383b5b30732fa9caa3d3a185 Author: Andrea Corallo Date: Wed Dec 25 16:02:46 2019 +0100 never load a compilation unit without filling the func link table diff --git a/src/comp.c b/src/comp.c index 6f5658191c..9baa990061 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3113,14 +3113,19 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, } -void -fill_freloc (void) +static void +freloc_check_fill (void) { + if (freloc.size) + return; + if (ARRAYELTS (helper_link_table) > F_RELOC_MAX_SIZE) goto overflow; memcpy (freloc.link_table, helper_link_table, sizeof (helper_link_table)); freloc.size = ARRAYELTS (helper_link_table); + eassert (!NILP (Vcomp_subr_list)); + Lisp_Object subr_l = Vcomp_subr_list; FOR_EACH_TAIL (subr_l) { @@ -3136,12 +3141,6 @@ fill_freloc (void) fatal ("Overflowing function relocation table, increase F_RELOC_MAX_SIZE"); } -int -filled_freloc (void) -{ - return freloc.link_table[0] ? 1 : 0; -} - /******************************************************************************/ /* Helper functions called from the run-time. */ /* These can't be statics till shared mechanism is used to solve relocations. */ @@ -3217,6 +3216,8 @@ load_static_obj (dynlib_handle_ptr handle, const char *name) void load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u, bool loading_dump) { + freloc_check_fill (); + dynlib_handle_ptr handle = comp_u->handle; struct thread_state ***current_thread_reloc = dynlib_sym (handle, CURRENT_THREAD_RELOC_SYM); @@ -3303,9 +3304,6 @@ DEFUN ("native-elisp-load", Fnative_elisp_load, Snative_elisp_load, 1, 1, 0, { CHECK_STRING (file); - if (!freloc.link_table[0]) - xsignal2 (Qnative_lisp_load_failed, file, - build_string ("Empty relocation table")); struct Lisp_Native_Comp_Unit *comp_u = allocate_native_comp_unit(); comp_u->handle = dynlib_open (SSDATA (file)); if (!comp_u->handle) @@ -3430,7 +3428,8 @@ syms_of_comp (void) doc: /* The compiler context. */); Vcomp_ctxt = Qnil; - /* FIXME should be initialized but not here... */ + /* FIXME should be initialized but not here... Plus this don't have + to be necessarily exposed to lisp but can easy debug for now. */ DEFVAR_LISP ("comp-subr-list", Vcomp_subr_list, doc: /* List of all defined subrs. */); DEFVAR_LISP ("comp-sym-subr-c-name-h", Vcomp_sym_subr_c_name_h, diff --git a/src/comp.h b/src/comp.h index f756e38d29..33b7354800 100644 --- a/src/comp.h +++ b/src/comp.h @@ -60,10 +60,5 @@ XNATIVE_COMP_UNIT (Lisp_Object a) extern void load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u, bool loading_dump); extern void syms_of_comp (void); -/* Fill the freloc structure. Must be called before any eln is loaded. */ -extern void fill_freloc (void); -/* Return 1 if freloc is filled or 0 otherwise. */ -extern int filled_freloc (void); - #endif #endif diff --git a/src/emacs.c b/src/emacs.c index 0798e0702f..90ab7ac1e8 100644 --- a/src/emacs.c +++ b/src/emacs.c @@ -2050,10 +2050,6 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem moncontrol (0); #endif -#ifdef HAVE_NATIVE_COMP - fill_freloc (); -#endif - initialized = true; if (dump_mode) commit cedc19297e47473ae599faa7cbcb2f3f6c9d5846 Author: Andrea Corallo Date: Tue Dec 24 22:26:20 2019 +0100 add elns to the gitignore diff --git a/.gitignore b/.gitignore index d4be6bb23e..52816e8473 100644 --- a/.gitignore +++ b/.gitignore @@ -132,6 +132,7 @@ src/gl-stamp *.dll *.core *.elc +*.eln *.o *.res *.so commit e678021f0c3db705c91831cff466561fd73c3040 Author: Andrea Corallo Date: Tue Dec 24 20:38:13 2019 +0100 add batch-native-compile diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 6b9965b820..983ba0e0ba 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1886,6 +1886,11 @@ Return the compilation unit file name." (list input err-val)))))) data)) +;;;###autoload +(defun batch-native-compile () + "Ultra cheap impersonation of `batch-byte-compile'." + (mapc #'native-compile command-line-args-left)) + ;;;###autoload (defun native-compile-async (input &optional jobs recursively) "Compile INPUT asynchronously. commit ef59b67e4657fa80d1528b9d476c67f01abecc35 Author: Andrea Corallo Date: Tue Dec 24 17:41:44 2019 +0100 mitigate ifdef proliferation diff --git a/src/alloc.c b/src/alloc.c index 5e0b04b1cc..6d6f6934ba 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -3023,15 +3023,14 @@ cleanup_vector (struct Lisp_Vector *vector) if (uptr->finalizer) uptr->finalizer (uptr->p); } -#ifdef HAVE_NATIVE_COMP - else if (PSEUDOVECTOR_TYPEP (&vector->header, PVEC_NATIVE_COMP_UNIT)) + else if (NATIVE_COMP_FLAG + && PSEUDOVECTOR_TYPEP (&vector->header, PVEC_NATIVE_COMP_UNIT)) { struct Lisp_Native_Comp_Unit *cu = PSEUDOVEC_STRUCT (vector, Lisp_Native_Comp_Unit); eassert (cu->handle); dynlib_close (cu->handle); } -#endif } /* Reclaim space used by unmarked vectors. */ @@ -6565,14 +6564,12 @@ mark_object (Lisp_Object arg) break; case PVEC_SUBR: -#ifdef HAVE_NATIVE_COMP if (SUBRP_NATIVE_COMPILEDP (obj)) { set_vector_marked (ptr); struct Lisp_Subr *subr = XSUBR (obj); - mark_object (subr->native_comp_u); + mark_object (subr->native_comp_u[0]); } -#endif break; case PVEC_FREE: @@ -6717,13 +6714,9 @@ survives_gc_p (Lisp_Object obj) break; case Lisp_Vectorlike: -#ifdef HAVE_NATIVE_COMP survives_p = (SUBRP (obj) && !SUBRP_NATIVE_COMPILEDP (obj)) || vector_marked_p (XVECTOR (obj)); -#else - survives_p = SUBRP (obj) || vector_marked_p (XVECTOR (obj)); -#endif break; case Lisp_Cons: @@ -7473,14 +7466,14 @@ N should be nonnegative. */); static union Aligned_Lisp_Subr Swatch_gc_cons_threshold = {{{ PSEUDOVECTOR_FLAG | (PVEC_SUBR << PSEUDOVECTOR_AREA_BITS) }, { .a4 = watch_gc_cons_threshold }, - 4, 4, "watch_gc_cons_threshold", {0}, {0}, 0}}; + 4, 4, "watch_gc_cons_threshold", {0}, {0}}}; XSETSUBR (watcher, &Swatch_gc_cons_threshold.s); Fadd_variable_watcher (Qgc_cons_threshold, watcher); static union Aligned_Lisp_Subr Swatch_gc_cons_percentage = {{{ PSEUDOVECTOR_FLAG | (PVEC_SUBR << PSEUDOVECTOR_AREA_BITS) }, { .a4 = watch_gc_cons_percentage }, - 4, 4, "watch_gc_cons_percentage", {0}, {0}, 0}}; + 4, 4, "watch_gc_cons_percentage", {0}, {0}}}; XSETSUBR (watcher, &Swatch_gc_cons_percentage.s); Fadd_variable_watcher (Qgc_cons_percentage, watcher); } diff --git a/src/comp.c b/src/comp.c index 87986abee6..6f5658191c 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3285,7 +3285,7 @@ DEFUN ("comp--register-subr", Fcomp__register_subr, Scomp__register_subr, x->s.symbol_name = xstrdup (SSDATA (Fsymbol_name (name))); x->s.native_intspec = intspec; x->s.native_doc = doc; - x->s.native_comp_u = comp_u; + x->s.native_comp_u[0] = comp_u; Lisp_Object tem; XSETSUBR (tem, &x->s); set_symbol_function (name, tem); diff --git a/src/comp.h b/src/comp.h index 90b4f40426..f756e38d29 100644 --- a/src/comp.h +++ b/src/comp.h @@ -19,6 +19,16 @@ along with GNU Emacs. If not, see . */ #ifndef COMP_H #define COMP_H +/* To keep ifdefs under control. */ +enum { + NATIVE_COMP_FLAG = +#ifdef HAVE_NATIVE_COMP + 1 +#else + 0 +#endif +}; + #ifdef HAVE_NATIVE_COMP #include diff --git a/src/data.c b/src/data.c index 3fb0fc0a19..d20db4dc3a 100644 --- a/src/data.c +++ b/src/data.c @@ -881,7 +881,7 @@ DEFUN ("subr-native-comp-unit", Fsubr_native_comp_unit, (Lisp_Object subr) { CHECK_SUBR (subr); - return XSUBR (subr)->native_comp_u; + return XSUBR (subr)->native_comp_u[0]; } DEFUN ("native-comp-unit-file", Fnative_comp_unit_file, @@ -919,10 +919,9 @@ Value, if non-nil, is a list (interactive SPEC). */) if (SUBRP (fun)) { -#ifdef HAVE_NATIVE_COMP if (SUBRP_NATIVE_COMPILEDP (fun) && XSUBR (fun)->native_intspec) return XSUBR (fun)->native_intspec; -#endif + const char *spec = XSUBR (fun)->intspec; if (spec) return list2 (Qinteractive, diff --git a/src/doc.c b/src/doc.c index 9e1d839278..2c96fc15a7 100644 --- a/src/doc.c +++ b/src/doc.c @@ -510,12 +510,10 @@ store_function_docstring (Lisp_Object obj, EMACS_INT offset) XSETCAR (tem, make_fixnum (offset)); } } -#ifdef HAVE_NATIVE_COMP else if (SUBRP_NATIVE_COMPILEDP (fun)) { XSUBR (fun)->native_doc = Qnil; } -#endif /* Lisp_Subrs have a slot for it. */ else if (SUBRP (fun)) { diff --git a/src/eval.c b/src/eval.c index bf37ed9cef..253de05a65 100644 --- a/src/eval.c +++ b/src/eval.c @@ -219,14 +219,17 @@ void init_eval_once (void) { /* Don't forget to update docs (lispref node "Local Variables"). */ -#ifndef HAVE_NATIVE_COMP - max_specpdl_size = 1600; /* 1500 is not enough for cl-generic.el. */ - max_lisp_eval_depth = 800; -#else - /* Original values increased for comp.el. */ - max_specpdl_size = 2100; - max_lisp_eval_depth = 1400; -#endif + if (!NATIVE_COMP_FLAG) + { + max_specpdl_size = 1600; /* 1500 is not enough for cl-generic.el. */ + max_lisp_eval_depth = 800; + } + else + { + /* Original values increased for comp.el. */ + max_specpdl_size = 2100; + max_lisp_eval_depth = 1400; + } Vrun_hooks = Qnil; pdumper_do_now_and_after_load (init_eval_once_for_pdumper); } diff --git a/src/lisp.h b/src/lisp.h index c7e55057ad..a4cabc3485 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -2098,9 +2098,7 @@ struct Lisp_Subr EMACS_INT doc; Lisp_Object native_doc; }; -#ifdef HAVE_NATIVE_COMP - Lisp_Object native_comp_u; -#endif + Lisp_Object native_comp_u[NATIVE_COMP_FLAG]; } GCALIGNED_STRUCT; union Aligned_Lisp_Subr { @@ -3113,7 +3111,7 @@ CHECK_INTEGER (Lisp_Object x) static union Aligned_Lisp_Subr sname = \ {{{ PVEC_SUBR << PSEUDOVECTOR_AREA_BITS }, \ { .a ## maxargs = fnname }, \ - minargs, maxargs, lname, {intspec}, {0}, 0}}; \ + minargs, maxargs, lname, {intspec}, {0}}}; \ Lisp_Object fnname /* defsubr (Sname); @@ -4763,7 +4761,7 @@ extern char *emacs_root_dir (void); INLINE bool SUBRP_NATIVE_COMPILEDP (Lisp_Object a) { - return SUBRP (a) && XSUBR (a)->native_comp_u; + return SUBRP (a) && XSUBR (a)->native_comp_u[0]; } INLINE struct Lisp_Native_Comp_Unit * @@ -4772,6 +4770,13 @@ allocate_native_comp_unit (void) return ALLOCATE_ZEROED_PSEUDOVECTOR (struct Lisp_Native_Comp_Unit, data_vec, PVEC_NATIVE_COMP_UNIT); } +#else +INLINE bool +SUBRP_NATIVE_COMPILEDP (Lisp_Object a) +{ + return false; +} + #endif /* Defined in lastfile.c. */ diff --git a/src/lread.c b/src/lread.c index 4e8a3adeb9..1c5268d0da 100644 --- a/src/lread.c +++ b/src/lread.c @@ -1281,11 +1281,9 @@ Return t if the file exists and loads successfully. */) bool is_module = false; #endif -#ifdef HAVE_NATIVE_COMP - bool is_native_elisp = suffix_p (found, NATIVE_ELISP_SUFFIX); -#else - bool is_native_elisp = false; -#endif + bool is_native_elisp = + NATIVE_COMP_FLAG && suffix_p (found, NATIVE_ELISP_SUFFIX) ? true : false; + /* Check if we're stuck in a recursive load cycle. 2000-09-21: It's not possible to just check for the file loaded @@ -1486,15 +1484,16 @@ Return t if the file exists and loads successfully. */) } else if (is_native_elisp) { -#ifdef HAVE_NATIVE_COMP - specbind (Qcurrent_load_list, Qnil); - LOADHIST_ATTACH (found); - Fnative_elisp_load (found); - build_load_history (found, true); -#else - /* This cannot happen. */ - emacs_abort (); -#endif + if (NATIVE_COMP_FLAG) + { + specbind (Qcurrent_load_list, Qnil); + LOADHIST_ATTACH (found); + Fnative_elisp_load (found); + build_load_history (found, true); + } + else + /* This cannot happen. */ + emacs_abort (); } else { @@ -4465,9 +4464,8 @@ defsubr (union Aligned_Lisp_Subr *aname) XSETPVECTYPE (sname, PVEC_SUBR); XSETSUBR (tem, sname); set_symbol_function (sym, tem); -#ifdef HAVE_NATIVE_COMP - Vcomp_subr_list = Fcons (tem, Vcomp_subr_list); -#endif /* HAVE_NATIVE_COMP */ + if (NATIVE_COMP_FLAG) + Vcomp_subr_list = Fcons (tem, Vcomp_subr_list); } #ifdef NOTDEF /* Use fset in subr.el now! */ diff --git a/src/pdumper.c b/src/pdumper.c index 610b94b0a3..d66c4e9964 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -2948,18 +2948,13 @@ dump_subr (struct dump_context *ctx, const struct Lisp_Subr *subr) struct Lisp_Subr out; dump_object_start (ctx, &out, sizeof (out)); DUMP_FIELD_COPY (&out, subr, header.size); -#ifdef HAVE_NATIVE_COMP - if (subr->native_comp_u) + if (NATIVE_COMP_FLAG && subr->native_comp_u[0]) out.function.a0 = NULL; else dump_field_emacs_ptr (ctx, &out, subr, &subr->function.a0); -#else - dump_field_emacs_ptr (ctx, &out, subr, &subr->function.a0); -#endif DUMP_FIELD_COPY (&out, subr, min_args); DUMP_FIELD_COPY (&out, subr, max_args); -#ifdef HAVE_NATIVE_COMP - if (subr->native_comp_u) + if (NATIVE_COMP_FLAG && subr->native_comp_u[0]) { dump_field_fixup_later (ctx, &out, subr, &subr->symbol_name); dump_remember_cold_op (ctx, @@ -2974,15 +2969,11 @@ dump_subr (struct dump_context *ctx, const struct Lisp_Subr *subr) dump_field_emacs_ptr (ctx, &out, subr, &subr->intspec); DUMP_FIELD_COPY (&out, subr, doc); } - dump_field_lv (ctx, &out, subr, &subr->native_comp_u, WEIGHT_NORMAL); -#else - dump_field_emacs_ptr (ctx, &out, subr, &subr->symbol_name); - dump_field_emacs_ptr (ctx, &out, subr, &subr->intspec); - DUMP_FIELD_COPY (&out, subr, doc); -#endif + if (NATIVE_COMP_FLAG) + dump_field_lv (ctx, &out, subr, &subr->native_comp_u[0], WEIGHT_NORMAL); dump_off subr_off = dump_object_finish (ctx, &out, sizeof (out)); - if (ctx->flags.dump_object_contents && subr->native_comp_u) + if (ctx->flags.dump_object_contents && subr->native_comp_u[0]) /* We'll do the final addr relocation during VERY_LATE_RELOCS time after the compilation units has been loaded. */ dump_push (&ctx->dump_relocs[VERY_LATE_RELOCS], @@ -5320,7 +5311,7 @@ dump_do_dump_relocation (const uintptr_t dump_base, struct Lisp_Subr *subr = dump_ptr (dump_base, reloc_offset); Lisp_Object name = intern (subr->symbol_name); struct Lisp_Native_Comp_Unit *comp_u = - XNATIVE_COMP_UNIT (subr->native_comp_u); + XNATIVE_COMP_UNIT (subr->native_comp_u[0]); if (!comp_u->handle) error ("can't relocate native subr with not loaded compilation unit"); Lisp_Object c_name = Fgethash (name, Vcomp_sym_subr_c_name_h, Qnil); commit 2ccce1bc3954ce5f2faa0dcf7fa68ec5cae710ca Author: Andrea Corallo Date: Tue Dec 24 16:58:44 2019 +0100 some style fixes diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index e8a9b6c2b6..6b9965b820 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -406,7 +406,7 @@ Put PREFIX in front of it." "Byte compile FUNCTION-NAME spilling data from the byte compiler." (let* ((f (symbol-function function-name)) (func (make-comp-func :name function-name - :c-name (comp-c-func-name function-name"F") + :c-name (comp-c-func-name function-name "F") :doc (documentation f) :int-spec (interactive-form f)))) (when (byte-code-function-p f) diff --git a/src/comp.c b/src/comp.c index 7e25bdc925..87986abee6 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1824,7 +1824,7 @@ emit_ctxt_code (void) fields[n_frelocs++] = xmint_pointer (XCDR (el)); } - Lisp_Object subr_l = Vsubr_list; + Lisp_Object subr_l = Vcomp_subr_list; FOR_EACH_TAIL (subr_l) { struct Lisp_Subr *subr = XSUBR (XCAR (subr_l)); @@ -3121,7 +3121,7 @@ fill_freloc (void) memcpy (freloc.link_table, helper_link_table, sizeof (helper_link_table)); freloc.size = ARRAYELTS (helper_link_table); - Lisp_Object subr_l = Vsubr_list; + Lisp_Object subr_l = Vcomp_subr_list; FOR_EACH_TAIL (subr_l) { if (freloc.size == F_RELOC_MAX_SIZE) @@ -3290,7 +3290,7 @@ DEFUN ("comp--register-subr", Fcomp__register_subr, Scomp__register_subr, XSETSUBR (tem, &x->s); set_symbol_function (name, tem); - Fputhash (name, c_name, Vsym_subr_c_name_h); + Fputhash (name, c_name, Vcomp_sym_subr_c_name_h); LOADHIST_ATTACH (Fcons (Qdefun, name)); return Qnil; @@ -3431,12 +3431,12 @@ syms_of_comp (void) Vcomp_ctxt = Qnil; /* FIXME should be initialized but not here... */ - DEFVAR_LISP ("comp-subr-list", Vsubr_list, + DEFVAR_LISP ("comp-subr-list", Vcomp_subr_list, doc: /* List of all defined subrs. */); - DEFVAR_LISP ("comp-sym-subr-c-name-h", Vsym_subr_c_name_h, + DEFVAR_LISP ("comp-sym-subr-c-name-h", Vcomp_sym_subr_c_name_h, doc: /* Hash table symbol-function -> function-c-name. For internal use during */); - Vsym_subr_c_name_h = CALLN (Fmake_hash_table); + Vcomp_sym_subr_c_name_h = CALLN (Fmake_hash_table); } #endif /* HAVE_NATIVE_COMP */ diff --git a/src/lread.c b/src/lread.c index 1ba04835aa..4e8a3adeb9 100644 --- a/src/lread.c +++ b/src/lread.c @@ -4466,7 +4466,7 @@ defsubr (union Aligned_Lisp_Subr *aname) XSETSUBR (tem, sname); set_symbol_function (sym, tem); #ifdef HAVE_NATIVE_COMP - Vsubr_list = Fcons (tem, Vsubr_list); + Vcomp_subr_list = Fcons (tem, Vcomp_subr_list); #endif /* HAVE_NATIVE_COMP */ } diff --git a/src/pdumper.c b/src/pdumper.c index 5bfccb8ac9..610b94b0a3 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -5323,7 +5323,7 @@ dump_do_dump_relocation (const uintptr_t dump_base, XNATIVE_COMP_UNIT (subr->native_comp_u); if (!comp_u->handle) error ("can't relocate native subr with not loaded compilation unit"); - Lisp_Object c_name = Fgethash (name, Vsym_subr_c_name_h, Qnil); + Lisp_Object c_name = Fgethash (name, Vcomp_sym_subr_c_name_h, Qnil); if (NILP (c_name)) error ("missing label name"); void *func = dynlib_sym (comp_u->handle, SSDATA (c_name)); commit 568883c9be8bfbb15ea48ae0de2c117894e8db4e Author: Andrea Corallo Date: Tue Dec 24 16:52:40 2019 +0100 add native elisp subr pdumper support diff --git a/src/comp.c b/src/comp.c index 43b22a8680..7e25bdc925 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3202,8 +3202,6 @@ helper_PSEUDOVECTOR_TYPEP_XUNTAG (Lisp_Object a, enum pvec_type code) /* Functions used to load eln files. */ /**************************************/ -static Lisp_Object Vnative_elisp_refs_hash; - typedef char *(*comp_lit_str_func) (void); /* Deserialize read and return static object. */ @@ -3292,6 +3290,7 @@ DEFUN ("comp--register-subr", Fcomp__register_subr, Scomp__register_subr, XSETSUBR (tem, &x->s); set_symbol_function (name, tem); + Fputhash (name, c_name, Vsym_subr_c_name_h); LOADHIST_ATTACH (Fcons (Qdefun, name)); return Qnil; @@ -3434,13 +3433,10 @@ syms_of_comp (void) /* FIXME should be initialized but not here... */ DEFVAR_LISP ("comp-subr-list", Vsubr_list, doc: /* List of all defined subrs. */); - - /* Load mechanism. */ - staticpro (&Vnative_elisp_refs_hash); - Vnative_elisp_refs_hash - = make_hash_table (hashtest_eq, DEFAULT_HASH_SIZE, - DEFAULT_REHASH_SIZE, DEFAULT_REHASH_THRESHOLD, - Qnil, false); + DEFVAR_LISP ("comp-sym-subr-c-name-h", Vsym_subr_c_name_h, + doc: /* Hash table symbol-function -> function-c-name. For + internal use during */); + Vsym_subr_c_name_h = CALLN (Fmake_hash_table); } #endif /* HAVE_NATIVE_COMP */ diff --git a/src/pdumper.c b/src/pdumper.c index 2dbe6c73fb..5bfccb8ac9 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -198,6 +198,7 @@ enum dump_reloc_type RELOC_DUMP_TO_DUMP_PTR_RAW, /* dump_mpz = [rebuild bignum] */ RELOC_NATIVE_COMP_UNIT, + RELOC_NATIVE_SUBR, RELOC_BIGNUM, /* dump_lv = make_lisp_ptr (dump_lv + dump_base, type - RELOC_DUMP_TO_DUMP_LV) @@ -2979,7 +2980,15 @@ dump_subr (struct dump_context *ctx, const struct Lisp_Subr *subr) dump_field_emacs_ptr (ctx, &out, subr, &subr->intspec); DUMP_FIELD_COPY (&out, subr, doc); #endif - return dump_object_finish (ctx, &out, sizeof (out)); + + dump_off subr_off = dump_object_finish (ctx, &out, sizeof (out)); + if (ctx->flags.dump_object_contents && subr->native_comp_u) + /* We'll do the final addr relocation during VERY_LATE_RELOCS time + after the compilation units has been loaded. */ + dump_push (&ctx->dump_relocs[VERY_LATE_RELOCS], + list2 (make_fixnum (RELOC_NATIVE_SUBR), + dump_off_to_lisp (subr_off))); + return subr_off; } #ifdef HAVE_NATIVE_COMP @@ -2993,8 +3002,8 @@ dump_native_comp_unit (struct dump_context *ctx, dump_off comp_u_off = finish_dump_pvec (ctx, &out->header); if (ctx->flags.dump_object_contents) - /* We'll do the real elf load during the LATE_RELOCS_1 relocation time. */ - dump_push (&ctx->dump_relocs[LATE_RELOCS_1], + /* We'll do the real elf load during LATE_RELOCS relocation time. */ + dump_push (&ctx->dump_relocs[LATE_RELOCS], list2 (make_fixnum (RELOC_NATIVE_COMP_UNIT), dump_off_to_lisp (comp_u_off))); return comp_u_off; @@ -5304,8 +5313,25 @@ dump_do_dump_relocation (const uintptr_t dump_base, if (!comp_u->handle) error ("%s", dynlib_error ()); load_comp_unit (comp_u, true); + break; + } + case RELOC_NATIVE_SUBR: + { + struct Lisp_Subr *subr = dump_ptr (dump_base, reloc_offset); + Lisp_Object name = intern (subr->symbol_name); + struct Lisp_Native_Comp_Unit *comp_u = + XNATIVE_COMP_UNIT (subr->native_comp_u); + if (!comp_u->handle) + error ("can't relocate native subr with not loaded compilation unit"); + Lisp_Object c_name = Fgethash (name, Vsym_subr_c_name_h, Qnil); + if (NILP (c_name)) + error ("missing label name"); + void *func = dynlib_sym (comp_u->handle, SSDATA (c_name)); + if (!func) + error ("can't function in compilation unit"); + subr->function.a0 = func; + break; } - break; case RELOC_BIGNUM: { struct Lisp_Bignum *bignum = dump_ptr (dump_base, reloc_offset); commit b6d6e7feb75b792c74fe3e1d036b9edf540d771e Author: Andrea Corallo Date: Tue Dec 24 14:51:18 2019 +0100 add native compilation unit pdumper support diff --git a/src/comp.c b/src/comp.c index 003d3d7ca4..43b22a8680 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3217,7 +3217,7 @@ load_static_obj (dynlib_handle_ptr handle, const char *name) } void -load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u) +load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u, bool loading_dump) { dynlib_handle_ptr handle = comp_u->handle; struct thread_state ***current_thread_reloc = @@ -3237,22 +3237,26 @@ load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u) *current_thread_reloc = ¤t_thread; *pure_reloc = (EMACS_INT **)&pure; - /* Imported data. */ - Lisp_Object d_vec = load_static_obj (handle, TEXT_DATA_RELOC_SYM); - EMACS_INT d_vec_len = XFIXNUM (Flength (d_vec)); - - for (EMACS_INT i = 0; i < d_vec_len; i++) - data_relocs[i] = AREF (d_vec, i); - - comp_u->data_vec = d_vec; /* Imported functions. */ *freloc_link_table = freloc.link_table; - Lisp_Object comp_u_obj; - XSETNATIVE_COMP_UNIT (comp_u_obj, comp_u); + /* Imported data. */ + if (!loading_dump) + comp_u->data_vec = load_static_obj (handle, TEXT_DATA_RELOC_SYM); + + EMACS_INT d_vec_len = XFIXNUM (Flength (comp_u->data_vec)); + + for (EMACS_INT i = 0; i < d_vec_len; i++) + data_relocs[i] = AREF (comp_u->data_vec, i); - /* Executing this will perform all the expected environment modification. */ - top_level_run (comp_u_obj); + if (!loading_dump) + { + Lisp_Object comp_u_obj; + XSETNATIVE_COMP_UNIT (comp_u_obj, comp_u); + /* Executing this will perform all the expected environment + modification. */ + top_level_run (comp_u_obj); + } return; } @@ -3308,7 +3312,8 @@ DEFUN ("native-elisp-load", Fnative_elisp_load, Snative_elisp_load, 1, 1, 0, if (!comp_u->handle) xsignal2 (Qnative_lisp_load_failed, file, build_string (dynlib_error ())); comp_u->file = file; - load_comp_unit (comp_u); + comp_u->data_vec = Qnil; + load_comp_unit (comp_u, false); return Qt; } diff --git a/src/comp.h b/src/comp.h index c4849ba13d..90b4f40426 100644 --- a/src/comp.h +++ b/src/comp.h @@ -47,7 +47,8 @@ XNATIVE_COMP_UNIT (Lisp_Object a) } /* Defined in comp.c. */ -extern void load_comp_unit (struct Lisp_Native_Comp_Unit *); +extern void load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u, + bool loading_dump); extern void syms_of_comp (void); /* Fill the freloc structure. Must be called before any eln is loaded. */ extern void fill_freloc (void); diff --git a/src/pdumper.c b/src/pdumper.c index 4e770f79af..2dbe6c73fb 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -197,6 +197,7 @@ enum dump_reloc_type /* dump_ptr = dump_ptr + dump_base */ RELOC_DUMP_TO_DUMP_PTR_RAW, /* dump_mpz = [rebuild bignum] */ + RELOC_NATIVE_COMP_UNIT, RELOC_BIGNUM, /* dump_lv = make_lisp_ptr (dump_lv + dump_base, type - RELOC_DUMP_TO_DUMP_LV) @@ -2991,6 +2992,11 @@ dump_native_comp_unit (struct dump_context *ctx, out->handle = NULL; dump_off comp_u_off = finish_dump_pvec (ctx, &out->header); + if (ctx->flags.dump_object_contents) + /* We'll do the real elf load during the LATE_RELOCS_1 relocation time. */ + dump_push (&ctx->dump_relocs[LATE_RELOCS_1], + list2 (make_fixnum (RELOC_NATIVE_COMP_UNIT), + dump_off_to_lisp (comp_u_off))); return comp_u_off; } #endif @@ -5290,6 +5296,16 @@ dump_do_dump_relocation (const uintptr_t dump_base, dump_write_word_to_dump (dump_base, reloc_offset, value); break; } + case RELOC_NATIVE_COMP_UNIT: + { + struct Lisp_Native_Comp_Unit *comp_u = + dump_ptr (dump_base, reloc_offset); + comp_u->handle = dynlib_open (SSDATA (comp_u->file)); + if (!comp_u->handle) + error ("%s", dynlib_error ()); + load_comp_unit (comp_u, true); + } + break; case RELOC_BIGNUM: { struct Lisp_Bignum *bignum = dump_ptr (dump_base, reloc_offset); commit 15ac087712250b5ffeb4d162761b2495a5e572a3 Author: Andrea Corallo Date: Tue Dec 24 14:12:40 2019 +0100 add pdump relocation phases diff --git a/src/pdumper.c b/src/pdumper.c index 157457d30d..4e770f79af 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -341,6 +341,20 @@ dump_fingerprint (char const *label, fprintf (stderr, "%s: %.*s\n", label, hexbuf_size, hexbuf); } +/* To be used if some order in the relocation process has to be enforced. */ +enum reloc_phase + { + /* First to run. Place here every relocation with no dependecy. */ + EARLY_RELOCS, + /* Run just after EARLY_RELOCS. */ + LATE_RELOCS, + /* Relocated at the very last after all hooks has been run. All + lisp machinery (allocation included) is at disposal. */ + VERY_LATE_RELOCS, + /* Fake, must be last. */ + RELOC_NUM_PHASES + }; + /* Format of an Emacs dump file. All offsets are relative to the beginning of the file. An Emacs dump file is coupled to exactly the Emacs binary that produced it, so details of @@ -368,7 +382,7 @@ struct dump_header /* Relocation table for the dump file; each entry is a struct dump_reloc. */ - struct dump_table_locator dump_relocs; + struct dump_table_locator dump_relocs[RELOC_NUM_PHASES]; /* "Relocation" table we abuse to hold information about the location and type of each lisp object in the dump. We need for @@ -546,7 +560,7 @@ struct dump_context Lisp_Object cold_queue; /* Relocations in the dump. */ - Lisp_Object dump_relocs; + Lisp_Object dump_relocs[RELOC_NUM_PHASES]; /* Object starts. */ Lisp_Object object_starts; @@ -1430,7 +1444,7 @@ dump_reloc_dump_to_emacs_ptr_raw (struct dump_context *ctx, dump_off dump_offset) { if (ctx->flags.dump_object_contents) - dump_push (&ctx->dump_relocs, + dump_push (&ctx->dump_relocs[EARLY_RELOCS], list2 (make_fixnum (RELOC_DUMP_TO_EMACS_PTR_RAW), dump_off_to_lisp (dump_offset))); } @@ -1463,7 +1477,7 @@ dump_reloc_dump_to_dump_lv (struct dump_context *ctx, emacs_abort (); } - dump_push (&ctx->dump_relocs, + dump_push (&ctx->dump_relocs[EARLY_RELOCS], list2 (make_fixnum (reloc_type), dump_off_to_lisp (dump_offset))); } @@ -1479,7 +1493,7 @@ dump_reloc_dump_to_dump_ptr_raw (struct dump_context *ctx, dump_off dump_offset) { if (ctx->flags.dump_object_contents) - dump_push (&ctx->dump_relocs, + dump_push (&ctx->dump_relocs[EARLY_RELOCS], list2 (make_fixnum (RELOC_DUMP_TO_DUMP_PTR_RAW), dump_off_to_lisp (dump_offset))); } @@ -1512,7 +1526,7 @@ dump_reloc_dump_to_emacs_lv (struct dump_context *ctx, emacs_abort (); } - dump_push (&ctx->dump_relocs, + dump_push (&ctx->dump_relocs[EARLY_RELOCS], list2 (make_fixnum (reloc_type), dump_off_to_lisp (dump_offset))); } @@ -2229,7 +2243,7 @@ dump_bignum (struct dump_context *ctx, Lisp_Object object) Lisp_Bignum instead of the actual mpz field so that the relocation offset is aligned. The relocation-application code knows to actually advance past the header. */ - dump_push (&ctx->dump_relocs, + dump_push (&ctx->dump_relocs[EARLY_RELOCS], list2 (make_fixnum (RELOC_BIGNUM), dump_off_to_lisp (bignum_offset))); } @@ -4123,7 +4137,8 @@ types. */) ctx->symbol_aux = Qnil; ctx->copied_queue = Qnil; ctx->cold_queue = Qnil; - ctx->dump_relocs = Qnil; + for (int i = 0; i < RELOC_NUM_PHASES; ++i) + ctx->dump_relocs[i] = Qnil; ctx->object_starts = Qnil; ctx->emacs_relocs = Qnil; ctx->bignum_data = make_eq_hash_table (); @@ -4278,8 +4293,9 @@ types. */) /* Emit instructions for Emacs to execute when loading the dump. Note that this relocation information ends up in the cold section of the dump. */ - drain_reloc_list (ctx, dump_emit_dump_reloc, emacs_reloc_merger, - &ctx->dump_relocs, &ctx->header.dump_relocs); + for (int i = 0; i < RELOC_NUM_PHASES; ++i) + drain_reloc_list (ctx, dump_emit_dump_reloc, emacs_reloc_merger, + &ctx->dump_relocs[i], &ctx->header.dump_relocs[i]); unsigned number_hot_relocations = ctx->number_hot_relocations; ctx->number_hot_relocations = 0; unsigned number_discardable_relocations = ctx->number_discardable_relocations; @@ -4297,7 +4313,8 @@ types. */) eassert (NILP (ctx->deferred_symbols)); eassert (NILP (ctx->deferred_hash_tables)); eassert (NILP (ctx->fixups)); - eassert (NILP (ctx->dump_relocs)); + for (int i = 0; i < RELOC_NUM_PHASES; ++i) + eassert (NILP (ctx->dump_relocs[i])); eassert (NILP (ctx->emacs_relocs)); /* Dump is complete. Go back to the header and write the magic @@ -5295,11 +5312,12 @@ dump_do_dump_relocation (const uintptr_t dump_base, } static void -dump_do_all_dump_relocations (const struct dump_header *const header, - const uintptr_t dump_base) +dump_do_all_dump_reloc_for_phase (const struct dump_header *const header, + const uintptr_t dump_base, + const enum reloc_phase phase) { - struct dump_reloc *r = dump_ptr (dump_base, header->dump_relocs.offset); - dump_off nr_entries = header->dump_relocs.nr_entries; + struct dump_reloc *r = dump_ptr (dump_base, header->dump_relocs[phase].offset); + dump_off nr_entries = header->dump_relocs[phase].nr_entries; for (dump_off i = 0; i < nr_entries; ++i) dump_do_dump_relocation (dump_base, r[i]); } @@ -5511,7 +5529,8 @@ pdumper_load (const char *dump_filename) dump_public.start = dump_base; dump_public.end = dump_public.start + dump_size; - dump_do_all_dump_relocations (header, dump_base); + dump_do_all_dump_reloc_for_phase (header, dump_base, EARLY_RELOCS); + dump_do_all_dump_reloc_for_phase (header, dump_base, LATE_RELOCS); dump_do_all_emacs_relocations (header, dump_base); dump_mmap_discard_contents (§ions[DS_DISCARDABLE]); @@ -5522,6 +5541,7 @@ pdumper_load (const char *dump_filename) initialization. */ for (int i = 0; i < nr_dump_hooks; ++i) dump_hooks[i] (); + dump_do_all_dump_reloc_for_phase (header, dump_base, VERY_LATE_RELOCS); initialized = true; struct timespec load_timespec = commit 36ab5c6d49f8fbfb858844743223414e6f2f2564 Author: Andrea Corallo Date: Tue Dec 24 08:09:21 2019 +0100 some more pdumper integration support diff --git a/src/comp.c b/src/comp.c index 68b1cdf744..003d3d7ca4 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3136,6 +3136,12 @@ fill_freloc (void) fatal ("Overflowing function relocation table, increase F_RELOC_MAX_SIZE"); } +int +filled_freloc (void) +{ + return freloc.link_table[0] ? 1 : 0; +} + /******************************************************************************/ /* Helper functions called from the run-time. */ /* These can't be statics till shared mechanism is used to solve relocations. */ @@ -3210,7 +3216,7 @@ load_static_obj (dynlib_handle_ptr handle, const char *name) return Fread (make_string (res->data, res->len)); } -static void +void load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u) { dynlib_handle_ptr handle = comp_u->handle; @@ -3297,15 +3303,11 @@ DEFUN ("native-elisp-load", Fnative_elisp_load, Snative_elisp_load, 1, 1, 0, if (!freloc.link_table[0]) xsignal2 (Qnative_lisp_load_failed, file, build_string ("Empty relocation table")); - - dynlib_handle_ptr handle = dynlib_open (SSDATA (file)); - load_handle_stack = Fcons (make_mint_ptr (handle), load_handle_stack); - if (!handle) - xsignal2 (Qnative_lisp_load_failed, file, build_string (dynlib_error ())); struct Lisp_Native_Comp_Unit *comp_u = allocate_native_comp_unit(); + comp_u->handle = dynlib_open (SSDATA (file)); + if (!comp_u->handle) + xsignal2 (Qnative_lisp_load_failed, file, build_string (dynlib_error ())); comp_u->file = file; - comp_u->fd = fd_out; - comp_u->handle = handle; load_comp_unit (comp_u); return Qt; diff --git a/src/comp.h b/src/comp.h index 36ee5d10e4..c4849ba13d 100644 --- a/src/comp.h +++ b/src/comp.h @@ -30,8 +30,6 @@ struct Lisp_Native_Comp_Unit Lisp_Object file; /* Analogous to the constant vector but per compilation unit. */ Lisp_Object data_vec; - /* Compilation unit file descriptor and handle. */ - int fd; dynlib_handle_ptr handle; }; @@ -49,8 +47,12 @@ XNATIVE_COMP_UNIT (Lisp_Object a) } /* Defined in comp.c. */ +extern void load_comp_unit (struct Lisp_Native_Comp_Unit *); extern void syms_of_comp (void); +/* Fill the freloc structure. Must be called before any eln is loaded. */ extern void fill_freloc (void); +/* Return 1 if freloc is filled or 0 otherwise. */ +extern int filled_freloc (void); #endif #endif diff --git a/src/pdumper.c b/src/pdumper.c index 775f6c3e60..157457d30d 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -446,6 +446,7 @@ enum cold_op COLD_OP_CHARSET, COLD_OP_BUFFER, COLD_OP_BIGNUM, + COLD_OP_NATIVE_SUBR, }; /* This structure controls what operations we perform inside @@ -939,7 +940,7 @@ dump_note_reachable (struct dump_context *ctx, Lisp_Object object) static void * dump_object_emacs_ptr (Lisp_Object lv) { - if (SUBRP (lv)) + if (SUBRP (lv) && !SUBRP_NATIVE_COMPILEDP (lv)) return XSUBR (lv); if (dump_builtin_symbol_p (lv)) return XSYMBOL (lv); @@ -2941,20 +2942,25 @@ dump_subr (struct dump_context *ctx, const struct Lisp_Subr *subr) #endif DUMP_FIELD_COPY (&out, subr, min_args); DUMP_FIELD_COPY (&out, subr, max_args); - dump_field_emacs_ptr (ctx, &out, subr, &subr->symbol_name); #ifdef HAVE_NATIVE_COMP if (subr->native_comp_u) { + dump_field_fixup_later (ctx, &out, subr, &subr->symbol_name); + dump_remember_cold_op (ctx, + COLD_OP_NATIVE_SUBR, + make_lisp_ptr ((void *) subr, Lisp_Vectorlike)); dump_field_lv (ctx, &out, subr, &subr->native_intspec, WEIGHT_NORMAL); dump_field_lv (ctx, &out, subr, &subr->native_doc, WEIGHT_NORMAL); } else { + dump_field_emacs_ptr (ctx, &out, subr, &subr->symbol_name); dump_field_emacs_ptr (ctx, &out, subr, &subr->intspec); DUMP_FIELD_COPY (&out, subr, doc); } dump_field_lv (ctx, &out, subr, &subr->native_comp_u, WEIGHT_NORMAL); #else + dump_field_emacs_ptr (ctx, &out, subr, &subr->symbol_name); dump_field_emacs_ptr (ctx, &out, subr, &subr->intspec); DUMP_FIELD_COPY (&out, subr, doc); #endif @@ -2968,9 +2974,10 @@ dump_native_comp_unit (struct dump_context *ctx, { START_DUMP_PVEC (ctx, &comp_u->header, struct Lisp_Native_Comp_Unit, out); dump_pseudovector_lisp_fields (ctx, &out->header, &comp_u->header); - out->fd = 0; - out->handle = 0; - return finish_dump_pvec (ctx, &out->header); + out->handle = NULL; + + dump_off comp_u_off = finish_dump_pvec (ctx, &out->header); + return comp_u_off; } #endif @@ -3051,6 +3058,11 @@ dump_vectorlike (struct dump_context *ctx, case PVEC_BIGNUM: offset = dump_bignum (ctx, lv); break; +#ifdef HAVE_NATIVE_COMP + case PVEC_NATIVE_COMP_UNIT: + offset = dump_native_comp_unit (ctx, XNATIVE_COMP_UNIT (lv)); + break; +#endif case PVEC_WINDOW_CONFIGURATION: error_unsupported_dump_object (ctx, lv, "window configuration"); case PVEC_OTHER: @@ -3075,11 +3087,6 @@ dump_vectorlike (struct dump_context *ctx, error_unsupported_dump_object (ctx, lv, "condvar"); case PVEC_MODULE_FUNCTION: error_unsupported_dump_object (ctx, lv, "module function"); -#ifdef HAVE_NATIVE_COMP - case PVEC_NATIVE_COMP_UNIT: - offset = dump_native_comp_unit (ctx, XNATIVE_COMP_UNIT (lv)); - break; -#endif default: error_unsupported_dump_object(ctx, lv, "weird pseudovector"); } @@ -3454,6 +3461,22 @@ dump_cold_bignum (struct dump_context *ctx, Lisp_Object object) } } +static void +dump_cold_native_subr (struct dump_context *ctx, Lisp_Object subr) +{ + /* Dump subr contents. */ + dump_off subr_offset = dump_recall_object (ctx, subr); + eassert (subr_offset > 0); + dump_remember_fixup_ptr_raw + (ctx, + subr_offset + dump_offsetof (struct Lisp_Subr, symbol_name), + ctx->offset); + const char *symbol_name = XSUBR (subr)->symbol_name; + ALLOW_IMPLICIT_CONVERSION; + dump_write (ctx, symbol_name, 1 + strlen (symbol_name)); + DISALLOW_IMPLICIT_CONVERSION; +} + static void dump_drain_cold_data (struct dump_context *ctx) { @@ -3497,6 +3520,9 @@ dump_drain_cold_data (struct dump_context *ctx) case COLD_OP_BIGNUM: dump_cold_bignum (ctx, data); break; + case COLD_OP_NATIVE_SUBR: + dump_cold_native_subr (ctx, data); + break; default: emacs_abort (); } @@ -3916,7 +3942,7 @@ dump_do_fixup (struct dump_context *ctx, /* Dump wants a pointer to a Lisp object. If DUMP_FIXUP_LISP_OBJECT_RAW, we should stick a C pointer in the dump; otherwise, a Lisp_Object. */ - if (SUBRP (arg)) + if (SUBRP (arg) && !SUBRP_NATIVE_COMPILEDP(arg)) { dump_value = emacs_offset (XSUBR (arg)); if (type == DUMP_FIXUP_LISP_OBJECT) commit 080dacda7896e0eb5ee54b1550097e45a4f423de Author: Andrea Corallo Date: Tue Dec 24 08:18:08 2019 +0100 Revert "split out copy_file_fd" This reverts commit 41203ad6abceb6dca39b2dab0adbd8fa711e1f89. diff --git a/src/fileio.c b/src/fileio.c index 91e0efc0a8..6e2fe2f0b8 100644 --- a/src/fileio.c +++ b/src/fileio.c @@ -1989,55 +1989,6 @@ clone_file (int dest, int source) } #endif -/* Copy data to OFD from IFD if possible. Return NEWSIZE. */ -off_t -copy_file_fd (int ofd, int ifd, struct stat *st, Lisp_Object newname, - Lisp_Object file) -{ - off_t newsize; - - if (clone_file (ofd, ifd)) - newsize = st->st_size; - else - { - off_t insize = st->st_size; - ssize_t copied; - - for (newsize = 0; newsize < insize; newsize += copied) - { - /* Copy at most COPY_MAX bytes at a time; this is min - (PTRDIFF_MAX, SIZE_MAX) truncated to a value that is - surely aligned well. */ - ssize_t ssize_max = TYPE_MAXIMUM (ssize_t); - ptrdiff_t copy_max = min (ssize_max, SIZE_MAX) >> 30 << 30; - off_t intail = insize - newsize; - ptrdiff_t len = min (intail, copy_max); - copied = copy_file_range (ifd, NULL, ofd, NULL, len, 0); - if (copied <= 0) - break; - maybe_quit (); - } - - /* Fall back on read+write if copy_file_range failed, or if the - input is empty and so could be a /proc file. read+write will - either succeed, or report an error more precisely than - copy_file_range would. */ - if (newsize != insize || insize == 0) - { - char buf[MAX_ALLOCA]; - for (; (copied = emacs_read_quit (ifd, buf, sizeof buf)); - newsize += copied) - { - if (copied < 0) - report_file_error ("Read error", file); - if (emacs_write_quit (ofd, buf, copied) != copied) - report_file_error ("Write error", newname); - } - } - } - return newsize; -} - DEFUN ("copy-file", Fcopy_file, Scopy_file, 2, 6, "fCopy file: \nGCopy %s to file: \np\nP", doc: /* Copy FILE to NEWNAME. Both args must be strings. @@ -2192,7 +2143,45 @@ permissions. */) maybe_quit (); - newsize = copy_file_fd (ofd, ifd, &st, newname, file); + if (clone_file (ofd, ifd)) + newsize = st.st_size; + else + { + off_t insize = st.st_size; + ssize_t copied; + + for (newsize = 0; newsize < insize; newsize += copied) + { + /* Copy at most COPY_MAX bytes at a time; this is min + (PTRDIFF_MAX, SIZE_MAX) truncated to a value that is + surely aligned well. */ + ssize_t ssize_max = TYPE_MAXIMUM (ssize_t); + ptrdiff_t copy_max = min (ssize_max, SIZE_MAX) >> 30 << 30; + off_t intail = insize - newsize; + ptrdiff_t len = min (intail, copy_max); + copied = copy_file_range (ifd, NULL, ofd, NULL, len, 0); + if (copied <= 0) + break; + maybe_quit (); + } + + /* Fall back on read+write if copy_file_range failed, or if the + input is empty and so could be a /proc file. read+write will + either succeed, or report an error more precisely than + copy_file_range would. */ + if (newsize != insize || insize == 0) + { + char buf[MAX_ALLOCA]; + for (; (copied = emacs_read_quit (ifd, buf, sizeof buf)); + newsize += copied) + { + if (copied < 0) + report_file_error ("Read error", file); + if (emacs_write_quit (ofd, buf, copied) != copied) + report_file_error ("Write error", newname); + } + } + } /* Truncate any existing output file after writing the data. This is more likely to work than truncation before writing, if the diff --git a/src/lisp.h b/src/lisp.h index 3c3a9e22cf..c7e55057ad 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -34,8 +34,6 @@ along with GNU Emacs. If not, see . */ #include #include -#include - INLINE_HEADER_BEGIN /* Define a TYPE constant ID as an externally visible name. Use like this: @@ -4320,7 +4318,6 @@ extern char *splice_dir_file (char *, char const *, char const *); extern bool file_name_absolute_p (const char *); extern char const *get_homedir (void); extern Lisp_Object expand_and_dir_to_file (Lisp_Object); -extern off_t copy_file_fd (int, int, struct stat *, Lisp_Object, Lisp_Object); extern Lisp_Object write_region (Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, int); commit df62baa7d4e8ce0760f32122899ae3c803180907 Author: Andrea Corallo Date: Tue Dec 24 08:17:40 2019 +0100 Revert "use memory mapped file for loading elns" This reverts commit 5e07231151ef60a5066617ef6cec7c0077825b1c. diff --git a/src/comp.c b/src/comp.c index 75b41e2af8..68b1cdf744 100644 --- a/src/comp.c +++ b/src/comp.c @@ -27,13 +27,6 @@ along with GNU Emacs. If not, see . */ #include #include -#include /* For getpid. */ -#include -#include /* For O_RDONLY. */ -#include -/* FIXME non portable. */ -#include /* For memfd_create. */ - #include "lisp.h" #include "puresize.h" #include "window.h" @@ -3305,22 +3298,8 @@ DEFUN ("native-elisp-load", Fnative_elisp_load, Snative_elisp_load, 1, 1, 0, xsignal2 (Qnative_lisp_load_failed, file, build_string ("Empty relocation table")); - /* FIXME non portable. */ - /* We copy the content of the file to be loaded in a memory mapped - file. We then keep track of this in the struct - Lisp_Native_Comp_Unit. In case this will be overwritten - or delete we'll dump the right data. */ - int fd_in = emacs_open (SSDATA (file), O_RDONLY, 0); - int fd_out = memfd_create (SSDATA (file), 0); - if (fd_in < 0 || fd_out < 0) - xsignal2 (Qnative_lisp_load_failed, file, - build_string ("Failing to get file descriptor")); - struct stat st; - if (fstat (fd_in, &st) != 0) - report_file_error ("Input file status", file); - copy_file_fd (fd_out, fd_in, &st, Qnil, file); - dynlib_handle_ptr handle = - dynlib_open (format_string ("/proc/%d/fd/%d", getpid (), fd_out)); + dynlib_handle_ptr handle = dynlib_open (SSDATA (file)); + load_handle_stack = Fcons (make_mint_ptr (handle), load_handle_stack); if (!handle) xsignal2 (Qnative_lisp_load_failed, file, build_string (dynlib_error ())); struct Lisp_Native_Comp_Unit *comp_u = allocate_native_comp_unit(); commit 8b1d9b8e5ed8035bd2f42517bb6bc3c8a6d6f0ae Author: Andrea Corallo Date: Mon Dec 23 14:27:55 2019 +0100 add initial native compiler pdumper support diff --git a/src/doc.c b/src/doc.c index 369997a3db..9e1d839278 100644 --- a/src/doc.c +++ b/src/doc.c @@ -510,13 +510,15 @@ store_function_docstring (Lisp_Object obj, EMACS_INT offset) XSETCAR (tem, make_fixnum (offset)); } } - +#ifdef HAVE_NATIVE_COMP + else if (SUBRP_NATIVE_COMPILEDP (fun)) + { + XSUBR (fun)->native_doc = Qnil; + } +#endif /* Lisp_Subrs have a slot for it. */ else if (SUBRP (fun)) { -#ifdef HAVE_NATIVE_COMP - eassert (NILP (Fsubr_native_elisp_p (fun))); -#endif XSUBR (fun)->doc = offset; } diff --git a/src/pdumper.c b/src/pdumper.c index 24698d48b5..775f6c3e60 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -2931,18 +2931,49 @@ dump_subr (struct dump_context *ctx, const struct Lisp_Subr *subr) struct Lisp_Subr out; dump_object_start (ctx, &out, sizeof (out)); DUMP_FIELD_COPY (&out, subr, header.size); +#ifdef HAVE_NATIVE_COMP + if (subr->native_comp_u) + out.function.a0 = NULL; + else + dump_field_emacs_ptr (ctx, &out, subr, &subr->function.a0); +#else dump_field_emacs_ptr (ctx, &out, subr, &subr->function.a0); +#endif DUMP_FIELD_COPY (&out, subr, min_args); DUMP_FIELD_COPY (&out, subr, max_args); dump_field_emacs_ptr (ctx, &out, subr, &subr->symbol_name); +#ifdef HAVE_NATIVE_COMP + if (subr->native_comp_u) + { + dump_field_lv (ctx, &out, subr, &subr->native_intspec, WEIGHT_NORMAL); + dump_field_lv (ctx, &out, subr, &subr->native_doc, WEIGHT_NORMAL); + } + else + { + dump_field_emacs_ptr (ctx, &out, subr, &subr->intspec); + DUMP_FIELD_COPY (&out, subr, doc); + } + dump_field_lv (ctx, &out, subr, &subr->native_comp_u, WEIGHT_NORMAL); +#else dump_field_emacs_ptr (ctx, &out, subr, &subr->intspec); DUMP_FIELD_COPY (&out, subr, doc); -#ifdef HAVE_NATIVE_COMP - dump_field_emacs_ptr (ctx, &out, subr, &subr->native_comp_u); #endif return dump_object_finish (ctx, &out, sizeof (out)); } +#ifdef HAVE_NATIVE_COMP +static dump_off +dump_native_comp_unit (struct dump_context *ctx, + const struct Lisp_Native_Comp_Unit *comp_u) +{ + START_DUMP_PVEC (ctx, &comp_u->header, struct Lisp_Native_Comp_Unit, out); + dump_pseudovector_lisp_fields (ctx, &out->header, &comp_u->header); + out->fd = 0; + out->handle = 0; + return finish_dump_pvec (ctx, &out->header); +} +#endif + static void fill_pseudovec (union vectorlike_header *header, Lisp_Object item) { @@ -3044,6 +3075,11 @@ dump_vectorlike (struct dump_context *ctx, error_unsupported_dump_object (ctx, lv, "condvar"); case PVEC_MODULE_FUNCTION: error_unsupported_dump_object (ctx, lv, "module function"); +#ifdef HAVE_NATIVE_COMP + case PVEC_NATIVE_COMP_UNIT: + offset = dump_native_comp_unit (ctx, XNATIVE_COMP_UNIT (lv)); + break; +#endif default: error_unsupported_dump_object(ctx, lv, "weird pseudovector"); } commit ca8d5ed6ecd5ca3eafa2923ee04e56dc474bd964 Author: Andrea Corallo Date: Mon Dec 23 11:51:33 2019 +0100 add disassemble support for native compiled functions diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 49f25d85c0..e8a9b6c2b6 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -360,12 +360,12 @@ VERBOSITY is a number between 0 and 3." ;;; spill-lap pass specific code. -(defun comp-c-func-name (symbol prefix) - "Given SYMBOL return a name suitable for the native code. +(defun comp-c-func-name (name prefix) + "Given NAME return a name suitable for the native code. Put PREFIX in front of it." ;; Unfortunatelly not all symbol names are valid as C function names... ;; Nassi's algorithm here: - (let* ((orig-name (symbol-name symbol)) + (let* ((orig-name (if (symbolp name) (symbol-name name) name)) (crypted (cl-loop with str = (make-string (* 2 (length orig-name)) 0) for j from 0 by 2 for i across orig-name diff --git a/lisp/emacs-lisp/disass.el b/lisp/emacs-lisp/disass.el index 51b7db24f3..c23dbe1e06 100644 --- a/lisp/emacs-lisp/disass.el +++ b/lisp/emacs-lisp/disass.el @@ -43,6 +43,8 @@ ;; Since we don't use byte-decompile-lapcode, let's try not loading byte-opt. (require 'byte-compile "bytecomp") +(declare-function comp-c-func-name "comp.el") + (defvar disassemble-column-1-indent 8 "*") (defvar disassemble-column-2-indent 10 "*") @@ -75,7 +77,7 @@ redefine OBJECT if it is a symbol." nil) -(defun disassemble-internal (obj indent interactive-p) +(cl-defun disassemble-internal (obj indent interactive-p) (let ((macro 'nil) (name (when (symbolp obj) (prog1 obj @@ -83,7 +85,26 @@ redefine OBJECT if it is a symbol." args) (setq obj (autoload-do-load obj name)) (if (subrp obj) - (error "Can't disassemble #" name)) + (if (and (fboundp 'subr-native-elisp-p) + (subr-native-elisp-p obj)) + (progn + (require 'comp) + (call-process "objdump" nil (current-buffer) t "-S" + (native-comp-unit-file (subr-native-comp-unit obj))) + (goto-char (point-min)) + (re-search-forward (concat "^.*" + (regexp-quote + (concat "<" + (comp-c-func-name + (subr-name obj) "F") + ">:")))) + (beginning-of-line) + (delete-region (point-min) (point)) + (when (re-search-forward "^.*<.*>:" nil t 2) + (delete-region (match-beginning 0) (point-max))) + (asm-mode) + (cl-return-from disassemble-internal)) + (error "Can't disassemble #" name))) (if (eq (car-safe obj) 'macro) ;Handle macros. (setq macro t obj (cdr obj))) commit df0a7547cbaf19152a74b5dda760e5d1f6c92ecc Author: Andrea Corallo Date: Mon Dec 23 09:40:41 2019 +0100 add native-comp-unit-file primitive diff --git a/src/data.c b/src/data.c index 70f8a8f2c1..3fb0fc0a19 100644 --- a/src/data.c +++ b/src/data.c @@ -883,6 +883,15 @@ DEFUN ("subr-native-comp-unit", Fsubr_native_comp_unit, CHECK_SUBR (subr); return XSUBR (subr)->native_comp_u; } + +DEFUN ("native-comp-unit-file", Fnative_comp_unit_file, + Snative_comp_unit_file, 1, 1, 0, + doc: /* Return the file of the native compilation unit. */) + (Lisp_Object object) +{ + CHECK_TYPE (NATIVE_COMP_UNITP (object), Qnative_comp_unit, object); + return XNATIVE_COMP_UNIT (object)->file; +} #endif DEFUN ("interactive-form", Finteractive_form, Sinteractive_form, 1, 1, 0, @@ -4011,7 +4020,8 @@ syms_of_data (void) defsubr (&Ssubr_name); #ifdef HAVE_NATIVE_COMP defsubr (&Ssubr_native_elisp_p); - defsubr (&Ssubr_native_compilation_unit); + defsubr (&Ssubr_native_comp_unit); + defsubr (&Snative_comp_unit_file); #endif #ifdef HAVE_MODULES defsubr (&Suser_ptrp); commit 12639610f78f9006b70933bfc6898c1312f95290 Author: Andrea Corallo Date: Mon Dec 23 09:24:51 2019 +0100 better printing for native compilation unit diff --git a/src/comp.h b/src/comp.h index 677ffdc4d7..36ee5d10e4 100644 --- a/src/comp.h +++ b/src/comp.h @@ -26,7 +26,7 @@ along with GNU Emacs. If not, see . */ struct Lisp_Native_Comp_Unit { union vectorlike_header header; - /* Original eln file loaded (just for debug purpose). */ + /* Original eln file loaded. */ Lisp_Object file; /* Analogous to the constant vector but per compilation unit. */ Lisp_Object data_vec; diff --git a/src/print.c b/src/print.c index 4d7932a81d..9013ccc8cc 100644 --- a/src/print.c +++ b/src/print.c @@ -1829,8 +1829,7 @@ print_vectorlike (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag, case PVEC_NATIVE_COMP_UNIT: { print_c_string ("#fd); - strout (buf, len, len, printcharfun); + print_string (XNATIVE_COMP_UNIT (obj)->file, printcharfun); printchar ('>', printcharfun); } break; commit fd3c00ff92826b466a3292a05072eb5b4f23a701 Author: Andrea Corallo Date: Mon Dec 23 09:04:24 2019 +0100 add subr-native-compilation-unit primitive diff --git a/src/data.c b/src/data.c index 73ddb021e2..70f8a8f2c1 100644 --- a/src/data.c +++ b/src/data.c @@ -867,13 +867,22 @@ SUBR must be a built-in function. */) } #ifdef HAVE_NATIVE_COMP -DEFUN ("subr-native-elisp-p", Fsubr_native_elisp_p, Ssubr_native_elisp_p, 1, 1, 0, - doc: /* Return t if the object is native compiled lisp function, +DEFUN ("subr-native-elisp-p", Fsubr_native_elisp_p, Ssubr_native_elisp_p, 1, 1, + 0, doc: /* Return t if the object is native compiled lisp function, nil otherwise. */) (Lisp_Object object) { return SUBRP_NATIVE_COMPILEDP (object) ? Qt : Qnil; } + +DEFUN ("subr-native-comp-unit", Fsubr_native_comp_unit, + Ssubr_native_comp_unit, 1, 1, 0, + doc: /* Return the native compilation unit. */) + (Lisp_Object subr) +{ + CHECK_SUBR (subr); + return XSUBR (subr)->native_comp_u; +} #endif DEFUN ("interactive-form", Finteractive_form, Sinteractive_form, 1, 1, 0, @@ -4002,6 +4011,7 @@ syms_of_data (void) defsubr (&Ssubr_name); #ifdef HAVE_NATIVE_COMP defsubr (&Ssubr_native_elisp_p); + defsubr (&Ssubr_native_compilation_unit); #endif #ifdef HAVE_MODULES defsubr (&Suser_ptrp); commit 0a74771ee9c406cf98d391378340c79645c88d52 Author: Andrea Corallo Date: Sun Dec 22 09:58:33 2019 +0100 fix invalid read in fill_freloc diff --git a/src/comp.c b/src/comp.c index 6d496e89bf..75b41e2af8 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3125,7 +3125,7 @@ fill_freloc (void) { if (ARRAYELTS (helper_link_table) > F_RELOC_MAX_SIZE) goto overflow; - memcpy (freloc.link_table, helper_link_table, sizeof (freloc.link_table)); + memcpy (freloc.link_table, helper_link_table, sizeof (helper_link_table)); freloc.size = ARRAYELTS (helper_link_table); Lisp_Object subr_l = Vsubr_list; commit 5dae0a9a55101aeb668f90e1fece1ffbab5e7ee2 Author: Andrea Corallo Date: Sun Dec 22 09:52:46 2019 +0100 add support for native comp unit to type-of diff --git a/src/data.c b/src/data.c index fd20ecce69..73ddb021e2 100644 --- a/src/data.c +++ b/src/data.c @@ -265,6 +265,8 @@ for example, (type-of 1) returns `integer'. */) } case PVEC_MODULE_FUNCTION: return Qmodule_function; + case PVEC_NATIVE_COMP_UNIT: + return Qnative_comp_unit; case PVEC_XWIDGET: return Qxwidget; case PVEC_XWIDGET_VIEW: @@ -3876,6 +3878,7 @@ syms_of_data (void) DEFSYM (Qoverlay, "overlay"); DEFSYM (Qfinalizer, "finalizer"); DEFSYM (Qmodule_function, "module-function"); + DEFSYM (Qnative_comp_unit, "native-comp-unit"); DEFSYM (Quser_ptr, "user-ptr"); DEFSYM (Qfloat, "float"); DEFSYM (Qwindow_configuration, "window-configuration"); commit b275ddd63a24b15dd8f90ea0c4f27341a8dfa977 Author: Andrea Corallo Date: Sun Dec 22 09:28:39 2019 +0100 rationalize load functions diff --git a/src/comp.c b/src/comp.c index 9f8c24f3cf..6d496e89bf 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3218,9 +3218,8 @@ load_static_obj (dynlib_handle_ptr handle, const char *name) } static void -load_comp_unit (Lisp_Object comp_u_obj, Lisp_Object file) +load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u) { - struct Lisp_Native_Comp_Unit *comp_u = XNATIVE_COMP_UNIT (comp_u_obj); dynlib_handle_ptr handle = comp_u->handle; struct thread_state ***current_thread_reloc = dynlib_sym (handle, CURRENT_THREAD_RELOC_SYM); @@ -3234,7 +3233,7 @@ load_comp_unit (Lisp_Object comp_u_obj, Lisp_Object file) && data_relocs && freloc_link_table && top_level_run)) - xsignal1 (Qnative_lisp_file_inconsistent, file); + xsignal1 (Qnative_lisp_file_inconsistent, comp_u->file); *current_thread_reloc = ¤t_thread; *pure_reloc = (EMACS_INT **)&pure; @@ -3250,6 +3249,9 @@ load_comp_unit (Lisp_Object comp_u_obj, Lisp_Object file) /* Imported functions. */ *freloc_link_table = freloc.link_table; + Lisp_Object comp_u_obj; + XSETNATIVE_COMP_UNIT (comp_u_obj, comp_u); + /* Executing this will perform all the expected environment modification. */ top_level_run (comp_u_obj); @@ -3319,11 +3321,13 @@ DEFUN ("native-elisp-load", Fnative_elisp_load, Snative_elisp_load, 1, 1, 0, copy_file_fd (fd_out, fd_in, &st, Qnil, file); dynlib_handle_ptr handle = dynlib_open (format_string ("/proc/%d/fd/%d", getpid (), fd_out)); - Lisp_Object comp_u = make_native_comp_u (fd_in, handle); if (!handle) xsignal2 (Qnative_lisp_load_failed, file, build_string (dynlib_error ())); - - load_comp_unit (comp_u, file); + struct Lisp_Native_Comp_Unit *comp_u = allocate_native_comp_unit(); + comp_u->file = file; + comp_u->fd = fd_out; + comp_u->handle = handle; + load_comp_unit (comp_u); return Qt; } diff --git a/src/comp.h b/src/comp.h index 8b83911f53..677ffdc4d7 100644 --- a/src/comp.h +++ b/src/comp.h @@ -26,6 +26,8 @@ along with GNU Emacs. If not, see . */ struct Lisp_Native_Comp_Unit { union vectorlike_header header; + /* Original eln file loaded (just for debug purpose). */ + Lisp_Object file; /* Analogous to the constant vector but per compilation unit. */ Lisp_Object data_vec; /* Compilation unit file descriptor and handle. */ diff --git a/src/lisp.h b/src/lisp.h index 81ccae5683..3c3a9e22cf 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -4769,17 +4769,11 @@ SUBRP_NATIVE_COMPILEDP (Lisp_Object a) return SUBRP (a) && XSUBR (a)->native_comp_u; } -INLINE Lisp_Object -make_native_comp_u (int fd, dynlib_handle_ptr handle) -{ - struct Lisp_Native_Comp_Unit *x = - ALLOCATE_ZEROED_PSEUDOVECTOR (struct Lisp_Native_Comp_Unit, data_vec, - PVEC_NATIVE_COMP_UNIT); - x->fd = fd; - x->handle = handle; - Lisp_Object cu; - XSETNATIVE_COMP_UNIT (cu, x); - return cu; +INLINE struct Lisp_Native_Comp_Unit * +allocate_native_comp_unit (void) +{ + return ALLOCATE_ZEROED_PSEUDOVECTOR (struct Lisp_Native_Comp_Unit, data_vec, + PVEC_NATIVE_COMP_UNIT); } #endif commit 5ecb71c1e65038b79933c06e1c0303b3e58ef4b5 Author: Andrea Corallo Date: Sun Dec 22 09:14:07 2019 +0100 clean-up unnecessary function prevent_gc diff --git a/src/comp.c b/src/comp.c index 0ec0edd27e..9f8c24f3cf 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3204,11 +3204,6 @@ helper_PSEUDOVECTOR_TYPEP_XUNTAG (Lisp_Object a, enum pvec_type code) /**************************************/ static Lisp_Object Vnative_elisp_refs_hash; -static void -prevent_gc (Lisp_Object obj) -{ - Fputhash (obj, Qt, Vnative_elisp_refs_hash); -} typedef char *(*comp_lit_str_func) (void); commit 42362d991443689162c3e0bf1eb683a85481a391 Author: Andrea Corallo Date: Sun Dec 22 09:13:46 2019 +0100 remove load_handle_stack and use the implementation one diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 60eb942066..49f25d85c0 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1073,7 +1073,10 @@ the annotation emission." (make-comp-mvar :constant (comp-func-c-name f)) (make-comp-mvar :constant (comp-func-doc f)) (make-comp-mvar :constant - (comp-func-int-spec f)))))) + (comp-func-int-spec f)) + ;; This is the compilation unit it-self passed as + ;; parameter. + (make-comp-mvar :slot 0))))) (cl-defmethod comp-emit-for-top-level ((form byte-to-native-top-level)) (let ((form (byte-to-native-top-level-form form))) @@ -1083,17 +1086,24 @@ the annotation emission." (defun comp-limplify-top-level () "Create a limple function doing the business for top level forms. -This will be called at load-time." +This will be called at load-time. + +Synthesize a function called 'top_level_run' that gets one single +parameter (the compilation unit it-self). To define native +functions 'top_level_run' will call back `comp--register-subr' +into the C code forwarding the compilation unit." (let* ((func (make-comp-func :name 'top-level-run :c-name "top_level_run" - :args (make-comp-args :min 0 :max 0) - :frame-size 0)) + :args (make-comp-args :min 1 :max 1) + :frame-size 1)) (comp-func func) (comp-pass (make-comp-limplify :curr-block (make--comp-block -1 0 'top-level) - :frame (comp-new-frame 0)))) + :frame (comp-new-frame 1)))) (comp-make-curr-block 'entry (comp-sp)) (comp-emit-annotation "Top level") + ;; Assign the compilation unit incoming as parameter to the slot frame 0. + (comp-emit `(set-par-to-local ,(comp-slot-n 0) 0)) (mapc #'comp-emit-for-top-level (comp-ctxt-top-level-forms comp-ctxt)) (comp-emit `(return ,(make-comp-mvar :constant t))) (comp-limplify-finalize-function func))) diff --git a/src/comp.c b/src/comp.c index c74e5cf2e6..0ec0edd27e 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3204,8 +3204,6 @@ helper_PSEUDOVECTOR_TYPEP_XUNTAG (Lisp_Object a, enum pvec_type code) /**************************************/ static Lisp_Object Vnative_elisp_refs_hash; -static Lisp_Object load_handle_stack; - static void prevent_gc (Lisp_Object obj) { @@ -3234,7 +3232,7 @@ load_comp_unit (Lisp_Object comp_u_obj, Lisp_Object file) EMACS_INT ***pure_reloc = dynlib_sym (handle, PURE_RELOC_SYM); Lisp_Object *data_relocs = dynlib_sym (handle, DATA_RELOC_SYM); void **freloc_link_table = dynlib_sym (handle, IMPORTED_FUNC_LINK_TABLE); - void (*top_level_run)(void) = dynlib_sym (handle, "top_level_run"); + void (*top_level_run)(Lisp_Object) = dynlib_sym (handle, "top_level_run"); if (!(current_thread_reloc && pure_reloc @@ -3258,19 +3256,19 @@ load_comp_unit (Lisp_Object comp_u_obj, Lisp_Object file) *freloc_link_table = freloc.link_table; /* Executing this will perform all the expected environment modification. */ - top_level_run (); + top_level_run (comp_u_obj); return; } DEFUN ("comp--register-subr", Fcomp__register_subr, Scomp__register_subr, - 6, 6, 0, + 7, 7, 0, doc: /* This gets called by top_level_run during load phase to register each exported subr. */) (Lisp_Object name, Lisp_Object minarg, Lisp_Object maxarg, - Lisp_Object c_name, Lisp_Object doc, Lisp_Object intspec) + Lisp_Object c_name, Lisp_Object doc, Lisp_Object intspec, + Lisp_Object comp_u) { - Lisp_Object comp_u = XCAR (load_handle_stack); dynlib_handle_ptr handle = XNATIVE_COMP_UNIT (comp_u)->handle; if (!handle) xsignal0 (Qwrong_register_subr_call); @@ -3327,14 +3325,11 @@ DEFUN ("native-elisp-load", Fnative_elisp_load, Snative_elisp_load, 1, 1, 0, dynlib_handle_ptr handle = dynlib_open (format_string ("/proc/%d/fd/%d", getpid (), fd_out)); Lisp_Object comp_u = make_native_comp_u (fd_in, handle); - load_handle_stack = Fcons (comp_u, load_handle_stack); if (!handle) xsignal2 (Qnative_lisp_load_failed, file, build_string (dynlib_error ())); load_comp_unit (comp_u, file); - load_handle_stack = XCDR (load_handle_stack); - return Qt; } @@ -3461,8 +3456,6 @@ syms_of_comp (void) = make_hash_table (hashtest_eq, DEFAULT_HASH_SIZE, DEFAULT_REHASH_SIZE, DEFAULT_REHASH_THRESHOLD, Qnil, false); - staticpro (&load_handle_stack); - load_handle_stack = Qnil; } #endif /* HAVE_NATIVE_COMP */ commit a88e5f0f199ad018d57d07016dce20e5462dbbca Author: Andrea Corallo Date: Sun Dec 22 08:31:02 2019 +0100 better compilation unit definition diff --git a/src/alloc.c b/src/alloc.c index d47f9c8a57..5e0b04b1cc 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -6572,13 +6572,9 @@ mark_object (Lisp_Object arg) struct Lisp_Subr *subr = XSUBR (obj); mark_object (subr->native_comp_u); } - break; - case PVEC_NATIVE_COMP_UNIT: - set_vector_marked (ptr); - /* FIXME see comp.h. */ - mark_object (XNATIVE_COMP_UNIT (obj)->data_vec); #endif break; + case PVEC_FREE: emacs_abort (); diff --git a/src/comp.h b/src/comp.h index 04c5727866..8b83911f53 100644 --- a/src/comp.h +++ b/src/comp.h @@ -26,10 +26,11 @@ along with GNU Emacs. If not, see . */ struct Lisp_Native_Comp_Unit { union vectorlike_header header; + /* Analogous to the constant vector but per compilation unit. */ + Lisp_Object data_vec; /* Compilation unit file descriptor and handle. */ int fd; dynlib_handle_ptr handle; - Lisp_Object data_vec; /* FIXME this should be in the normal lisp slot. */ }; INLINE bool diff --git a/src/lisp.h b/src/lisp.h index 2e4a6c8984..81ccae5683 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -4773,10 +4773,8 @@ INLINE Lisp_Object make_native_comp_u (int fd, dynlib_handle_ptr handle) { struct Lisp_Native_Comp_Unit *x = - (struct Lisp_Native_Comp_Unit *) allocate_pseudovector ( - VECSIZE (struct Lisp_Native_Comp_Unit), - 0, VECSIZE (struct Lisp_Native_Comp_Unit), - PVEC_NATIVE_COMP_UNIT); + ALLOCATE_ZEROED_PSEUDOVECTOR (struct Lisp_Native_Comp_Unit, data_vec, + PVEC_NATIVE_COMP_UNIT); x->fd = fd; x->handle = handle; Lisp_Object cu; commit 4c8b46514d87856e5e2044bce804ad0156097d04 Author: Andrea Corallo Date: Sun Dec 22 08:12:27 2019 +0100 some rename on compilation unit struct diff --git a/src/alloc.c b/src/alloc.c index 547990c7a9..d47f9c8a57 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -3026,8 +3026,8 @@ cleanup_vector (struct Lisp_Vector *vector) #ifdef HAVE_NATIVE_COMP else if (PSEUDOVECTOR_TYPEP (&vector->header, PVEC_NATIVE_COMP_UNIT)) { - struct Lisp_Native_Compilation_Unit *cu = - PSEUDOVEC_STRUCT (vector, Lisp_Native_Compilation_Unit); + struct Lisp_Native_Comp_Unit *cu = + PSEUDOVEC_STRUCT (vector, Lisp_Native_Comp_Unit); eassert (cu->handle); dynlib_close (cu->handle); } @@ -6576,7 +6576,7 @@ mark_object (Lisp_Object arg) case PVEC_NATIVE_COMP_UNIT: set_vector_marked (ptr); /* FIXME see comp.h. */ - mark_object (XCOMPILATION_UNIT (obj)->data_vec); + mark_object (XNATIVE_COMP_UNIT (obj)->data_vec); #endif break; case PVEC_FREE: diff --git a/src/comp.c b/src/comp.c index 71d4d79f9e..c74e5cf2e6 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3227,7 +3227,7 @@ load_static_obj (dynlib_handle_ptr handle, const char *name) static void load_comp_unit (Lisp_Object comp_u_obj, Lisp_Object file) { - struct Lisp_Native_Compilation_Unit *comp_u = XCOMPILATION_UNIT (comp_u_obj); + struct Lisp_Native_Comp_Unit *comp_u = XNATIVE_COMP_UNIT (comp_u_obj); dynlib_handle_ptr handle = comp_u->handle; struct thread_state ***current_thread_reloc = dynlib_sym (handle, CURRENT_THREAD_RELOC_SYM); @@ -3271,7 +3271,7 @@ DEFUN ("comp--register-subr", Fcomp__register_subr, Scomp__register_subr, Lisp_Object c_name, Lisp_Object doc, Lisp_Object intspec) { Lisp_Object comp_u = XCAR (load_handle_stack); - dynlib_handle_ptr handle = XCOMPILATION_UNIT (comp_u)->handle; + dynlib_handle_ptr handle = XNATIVE_COMP_UNIT (comp_u)->handle; if (!handle) xsignal0 (Qwrong_register_subr_call); @@ -3313,7 +3313,7 @@ DEFUN ("native-elisp-load", Fnative_elisp_load, Snative_elisp_load, 1, 1, 0, /* FIXME non portable. */ /* We copy the content of the file to be loaded in a memory mapped file. We then keep track of this in the struct - Lisp_Native_Compilation_Unit. In case this will be overwritten + Lisp_Native_Comp_Unit. In case this will be overwritten or delete we'll dump the right data. */ int fd_in = emacs_open (SSDATA (file), O_RDONLY, 0); int fd_out = memfd_create (SSDATA (file), 0); diff --git a/src/comp.h b/src/comp.h index 876615e8dd..04c5727866 100644 --- a/src/comp.h +++ b/src/comp.h @@ -23,7 +23,7 @@ along with GNU Emacs. If not, see . */ #include -struct Lisp_Native_Compilation_Unit +struct Lisp_Native_Comp_Unit { union vectorlike_header header; /* Compilation unit file descriptor and handle. */ @@ -33,16 +33,16 @@ struct Lisp_Native_Compilation_Unit }; INLINE bool -COMPILATIONP_UNITP (Lisp_Object a) +NATIVE_COMP_UNITP (Lisp_Object a) { return PSEUDOVECTORP (a, PVEC_NATIVE_COMP_UNIT); } -INLINE struct Lisp_Native_Compilation_Unit * -XCOMPILATION_UNIT (Lisp_Object a) +INLINE struct Lisp_Native_Comp_Unit * +XNATIVE_COMP_UNIT (Lisp_Object a) { - eassert (COMPILATIONP_UNITP (a)); - return XUNTAG (a, Lisp_Vectorlike, struct Lisp_Native_Compilation_Unit); + eassert (NATIVE_COMP_UNITP (a)); + return XUNTAG (a, Lisp_Vectorlike, struct Lisp_Native_Comp_Unit); } /* Defined in comp.c. */ diff --git a/src/lisp.h b/src/lisp.h index 3d467a84d1..2e4a6c8984 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -4772,11 +4772,11 @@ SUBRP_NATIVE_COMPILEDP (Lisp_Object a) INLINE Lisp_Object make_native_comp_u (int fd, dynlib_handle_ptr handle) { - struct Lisp_Native_Compilation_Unit *x = - (struct Lisp_Native_Compilation_Unit *) allocate_pseudovector ( - VECSIZE (struct Lisp_Native_Compilation_Unit), - 0, VECSIZE (struct Lisp_Native_Compilation_Unit), - PVEC_NATIVE_COMP_UNIT); + struct Lisp_Native_Comp_Unit *x = + (struct Lisp_Native_Comp_Unit *) allocate_pseudovector ( + VECSIZE (struct Lisp_Native_Comp_Unit), + 0, VECSIZE (struct Lisp_Native_Comp_Unit), + PVEC_NATIVE_COMP_UNIT); x->fd = fd; x->handle = handle; Lisp_Object cu; diff --git a/src/print.c b/src/print.c index e7ddafbbbb..4d7932a81d 100644 --- a/src/print.c +++ b/src/print.c @@ -1829,7 +1829,7 @@ print_vectorlike (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag, case PVEC_NATIVE_COMP_UNIT: { print_c_string ("#fd); + int len = sprintf (buf, "%d", XNATIVE_COMP_UNIT (obj)->fd); strout (buf, len, len, printcharfun); printchar ('>', printcharfun); } commit c5bb62f99db4b1c70e68e7c7a30ede8227f199a3 Author: Andrea Corallo Date: Sat Dec 21 18:57:56 2019 +0100 initial gc support diff --git a/src/alloc.c b/src/alloc.c index dba2c2df88..547990c7a9 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -6567,10 +6567,18 @@ mark_object (Lisp_Object arg) case PVEC_SUBR: #ifdef HAVE_NATIVE_COMP if (SUBRP_NATIVE_COMPILEDP (obj)) - set_vector_marked (ptr); + { + set_vector_marked (ptr); + struct Lisp_Subr *subr = XSUBR (obj); + mark_object (subr->native_comp_u); + } + break; + case PVEC_NATIVE_COMP_UNIT: + set_vector_marked (ptr); + /* FIXME see comp.h. */ + mark_object (XCOMPILATION_UNIT (obj)->data_vec); #endif break; - case PVEC_FREE: emacs_abort (); diff --git a/src/comp.c b/src/comp.c index ea5d3238d2..71d4d79f9e 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3225,8 +3225,10 @@ load_static_obj (dynlib_handle_ptr handle, const char *name) } static void -load_comp_unit (dynlib_handle_ptr handle, Lisp_Object file) +load_comp_unit (Lisp_Object comp_u_obj, Lisp_Object file) { + struct Lisp_Native_Compilation_Unit *comp_u = XCOMPILATION_UNIT (comp_u_obj); + dynlib_handle_ptr handle = comp_u->handle; struct thread_state ***current_thread_reloc = dynlib_sym (handle, CURRENT_THREAD_RELOC_SYM); EMACS_INT ***pure_reloc = dynlib_sym (handle, PURE_RELOC_SYM); @@ -3249,11 +3251,9 @@ load_comp_unit (dynlib_handle_ptr handle, Lisp_Object file) EMACS_INT d_vec_len = XFIXNUM (Flength (d_vec)); for (EMACS_INT i = 0; i < d_vec_len; i++) - { data_relocs[i] = AREF (d_vec, i); - prevent_gc (data_relocs[i]); - } + comp_u->data_vec = d_vec; /* Imported functions. */ *freloc_link_table = freloc.link_table; @@ -3270,24 +3270,26 @@ DEFUN ("comp--register-subr", Fcomp__register_subr, Scomp__register_subr, (Lisp_Object name, Lisp_Object minarg, Lisp_Object maxarg, Lisp_Object c_name, Lisp_Object doc, Lisp_Object intspec) { - dynlib_handle_ptr handle = xmint_pointer (XCAR (load_handle_stack)); + Lisp_Object comp_u = XCAR (load_handle_stack); + dynlib_handle_ptr handle = XCOMPILATION_UNIT (comp_u)->handle; if (!handle) xsignal0 (Qwrong_register_subr_call); void *func = dynlib_sym (handle, SSDATA (c_name)); eassert (func); - /* FIXME add gc support, now just leaking. */ - union Aligned_Lisp_Subr *x = xmalloc (sizeof (*x)); - - x->s.header.size = PVEC_SUBR << PSEUDOVECTOR_AREA_BITS; + union Aligned_Lisp_Subr *x = + (union Aligned_Lisp_Subr *) allocate_pseudovector ( + VECSIZE (union Aligned_Lisp_Subr), + 0, VECSIZE (union Aligned_Lisp_Subr), + PVEC_SUBR); x->s.function.a0 = func; x->s.min_args = XFIXNUM (minarg); x->s.max_args = FIXNUMP (maxarg) ? XFIXNUM (maxarg) : MANY; x->s.symbol_name = xstrdup (SSDATA (Fsymbol_name (name))); x->s.native_intspec = intspec; x->s.native_doc = doc; - XSETPVECTYPE (&x->s, PVEC_SUBR); + x->s.native_comp_u = comp_u; Lisp_Object tem; XSETSUBR (tem, &x->s); set_symbol_function (name, tem); @@ -3324,11 +3326,12 @@ DEFUN ("native-elisp-load", Fnative_elisp_load, Snative_elisp_load, 1, 1, 0, copy_file_fd (fd_out, fd_in, &st, Qnil, file); dynlib_handle_ptr handle = dynlib_open (format_string ("/proc/%d/fd/%d", getpid (), fd_out)); - load_handle_stack = Fcons (make_mint_ptr (handle), load_handle_stack); + Lisp_Object comp_u = make_native_comp_u (fd_in, handle); + load_handle_stack = Fcons (comp_u, load_handle_stack); if (!handle) xsignal2 (Qnative_lisp_load_failed, file, build_string (dynlib_error ())); - load_comp_unit (handle, file); + load_comp_unit (comp_u, file); load_handle_stack = XCDR (load_handle_stack); diff --git a/src/comp.h b/src/comp.h index 457b678699..876615e8dd 100644 --- a/src/comp.h +++ b/src/comp.h @@ -29,6 +29,7 @@ struct Lisp_Native_Compilation_Unit /* Compilation unit file descriptor and handle. */ int fd; dynlib_handle_ptr handle; + Lisp_Object data_vec; /* FIXME this should be in the normal lisp slot. */ }; INLINE bool diff --git a/src/lisp.h b/src/lisp.h index 7a4b351757..3d467a84d1 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -1342,6 +1342,7 @@ dead_object (void) #define XSETTHREAD(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_THREAD)) #define XSETMUTEX(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_MUTEX)) #define XSETCONDVAR(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_CONDVAR)) +#define XSETNATIVE_COMP_UNIT(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_NATIVE_COMP_UNIT)) /* Efficiently convert a pointer to a Lisp object and back. The pointer is represented as a fixnum, so the garbage collector @@ -2100,7 +2101,7 @@ struct Lisp_Subr Lisp_Object native_doc; }; #ifdef HAVE_NATIVE_COMP - Lisp_Object native_comp_u;; + Lisp_Object native_comp_u; #endif } GCALIGNED_STRUCT; union Aligned_Lisp_Subr @@ -2138,14 +2139,6 @@ enum char_table_specials = PSEUDOVECSIZE (struct Lisp_Sub_Char_Table, contents) - 1 }; -#ifdef HAVE_NATIVE_COMP -INLINE bool -SUBRP_NATIVE_COMPILEDP (Lisp_Object a) -{ - return SUBRP (a) && XSUBR (a)->native_comp_u; -} -#endif - /* Sanity-check pseudovector layout. */ verify (offsetof (struct Lisp_Char_Table, defalt) == header_size); verify (offsetof (struct Lisp_Char_Table, extras) @@ -4769,6 +4762,29 @@ extern void syms_of_profiler (void); extern char *emacs_root_dir (void); #endif /* DOS_NT */ +#ifdef HAVE_NATIVE_COMP +INLINE bool +SUBRP_NATIVE_COMPILEDP (Lisp_Object a) +{ + return SUBRP (a) && XSUBR (a)->native_comp_u; +} + +INLINE Lisp_Object +make_native_comp_u (int fd, dynlib_handle_ptr handle) +{ + struct Lisp_Native_Compilation_Unit *x = + (struct Lisp_Native_Compilation_Unit *) allocate_pseudovector ( + VECSIZE (struct Lisp_Native_Compilation_Unit), + 0, VECSIZE (struct Lisp_Native_Compilation_Unit), + PVEC_NATIVE_COMP_UNIT); + x->fd = fd; + x->handle = handle; + Lisp_Object cu; + XSETNATIVE_COMP_UNIT (cu, x); + return cu; +} +#endif + /* Defined in lastfile.c. */ extern char my_edata[]; extern char my_endbss[]; diff --git a/src/print.c b/src/print.c index 2e2c863ece..e7ddafbbbb 100644 --- a/src/print.c +++ b/src/print.c @@ -1828,7 +1828,7 @@ print_vectorlike (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag, #ifdef HAVE_NATIVE_COMP case PVEC_NATIVE_COMP_UNIT: { - print_c_string ("#", printcharfun); + print_c_string ("#fd); strout (buf, len, len, printcharfun); printchar ('>', printcharfun); commit 79436f0c744a65ed2757f0119f5bd13e2fbef995 Author: Andrea Corallo Date: Fri Dec 20 22:32:19 2019 +0100 use memory mapped file for loading elns diff --git a/src/comp.c b/src/comp.c index 79ece461a5..ea5d3238d2 100644 --- a/src/comp.c +++ b/src/comp.c @@ -27,6 +27,13 @@ along with GNU Emacs. If not, see . */ #include #include +#include /* For getpid. */ +#include +#include /* For O_RDONLY. */ +#include +/* FIXME non portable. */ +#include /* For memfd_create. */ + #include "lisp.h" #include "puresize.h" #include "window.h" @@ -3301,7 +3308,22 @@ DEFUN ("native-elisp-load", Fnative_elisp_load, Snative_elisp_load, 1, 1, 0, xsignal2 (Qnative_lisp_load_failed, file, build_string ("Empty relocation table")); - dynlib_handle_ptr handle = dynlib_open (SSDATA (file)); + /* FIXME non portable. */ + /* We copy the content of the file to be loaded in a memory mapped + file. We then keep track of this in the struct + Lisp_Native_Compilation_Unit. In case this will be overwritten + or delete we'll dump the right data. */ + int fd_in = emacs_open (SSDATA (file), O_RDONLY, 0); + int fd_out = memfd_create (SSDATA (file), 0); + if (fd_in < 0 || fd_out < 0) + xsignal2 (Qnative_lisp_load_failed, file, + build_string ("Failing to get file descriptor")); + struct stat st; + if (fstat (fd_in, &st) != 0) + report_file_error ("Input file status", file); + copy_file_fd (fd_out, fd_in, &st, Qnil, file); + dynlib_handle_ptr handle = + dynlib_open (format_string ("/proc/%d/fd/%d", getpid (), fd_out)); load_handle_stack = Fcons (make_mint_ptr (handle), load_handle_stack); if (!handle) xsignal2 (Qnative_lisp_load_failed, file, build_string (dynlib_error ())); commit 54677f96f3ad8e489e04c8bc7875e1ec4d6b9a79 Author: Andrea Corallo Date: Fri Dec 20 21:04:59 2019 +0100 split out copy_file_fd diff --git a/src/fileio.c b/src/fileio.c index 6e2fe2f0b8..91e0efc0a8 100644 --- a/src/fileio.c +++ b/src/fileio.c @@ -1989,6 +1989,55 @@ clone_file (int dest, int source) } #endif +/* Copy data to OFD from IFD if possible. Return NEWSIZE. */ +off_t +copy_file_fd (int ofd, int ifd, struct stat *st, Lisp_Object newname, + Lisp_Object file) +{ + off_t newsize; + + if (clone_file (ofd, ifd)) + newsize = st->st_size; + else + { + off_t insize = st->st_size; + ssize_t copied; + + for (newsize = 0; newsize < insize; newsize += copied) + { + /* Copy at most COPY_MAX bytes at a time; this is min + (PTRDIFF_MAX, SIZE_MAX) truncated to a value that is + surely aligned well. */ + ssize_t ssize_max = TYPE_MAXIMUM (ssize_t); + ptrdiff_t copy_max = min (ssize_max, SIZE_MAX) >> 30 << 30; + off_t intail = insize - newsize; + ptrdiff_t len = min (intail, copy_max); + copied = copy_file_range (ifd, NULL, ofd, NULL, len, 0); + if (copied <= 0) + break; + maybe_quit (); + } + + /* Fall back on read+write if copy_file_range failed, or if the + input is empty and so could be a /proc file. read+write will + either succeed, or report an error more precisely than + copy_file_range would. */ + if (newsize != insize || insize == 0) + { + char buf[MAX_ALLOCA]; + for (; (copied = emacs_read_quit (ifd, buf, sizeof buf)); + newsize += copied) + { + if (copied < 0) + report_file_error ("Read error", file); + if (emacs_write_quit (ofd, buf, copied) != copied) + report_file_error ("Write error", newname); + } + } + } + return newsize; +} + DEFUN ("copy-file", Fcopy_file, Scopy_file, 2, 6, "fCopy file: \nGCopy %s to file: \np\nP", doc: /* Copy FILE to NEWNAME. Both args must be strings. @@ -2143,45 +2192,7 @@ permissions. */) maybe_quit (); - if (clone_file (ofd, ifd)) - newsize = st.st_size; - else - { - off_t insize = st.st_size; - ssize_t copied; - - for (newsize = 0; newsize < insize; newsize += copied) - { - /* Copy at most COPY_MAX bytes at a time; this is min - (PTRDIFF_MAX, SIZE_MAX) truncated to a value that is - surely aligned well. */ - ssize_t ssize_max = TYPE_MAXIMUM (ssize_t); - ptrdiff_t copy_max = min (ssize_max, SIZE_MAX) >> 30 << 30; - off_t intail = insize - newsize; - ptrdiff_t len = min (intail, copy_max); - copied = copy_file_range (ifd, NULL, ofd, NULL, len, 0); - if (copied <= 0) - break; - maybe_quit (); - } - - /* Fall back on read+write if copy_file_range failed, or if the - input is empty and so could be a /proc file. read+write will - either succeed, or report an error more precisely than - copy_file_range would. */ - if (newsize != insize || insize == 0) - { - char buf[MAX_ALLOCA]; - for (; (copied = emacs_read_quit (ifd, buf, sizeof buf)); - newsize += copied) - { - if (copied < 0) - report_file_error ("Read error", file); - if (emacs_write_quit (ofd, buf, copied) != copied) - report_file_error ("Write error", newname); - } - } - } + newsize = copy_file_fd (ofd, ifd, &st, newname, file); /* Truncate any existing output file after writing the data. This is more likely to work than truncation before writing, if the diff --git a/src/lisp.h b/src/lisp.h index 05d6ef0d22..7a4b351757 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -34,6 +34,8 @@ along with GNU Emacs. If not, see . */ #include #include +#include + INLINE_HEADER_BEGIN /* Define a TYPE constant ID as an externally visible name. Use like this: @@ -4325,6 +4327,7 @@ extern char *splice_dir_file (char *, char const *, char const *); extern bool file_name_absolute_p (const char *); extern char const *get_homedir (void); extern Lisp_Object expand_and_dir_to_file (Lisp_Object); +extern off_t copy_file_fd (int, int, struct stat *, Lisp_Object, Lisp_Object); extern Lisp_Object write_region (Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, int); commit 9a8f33f285295daff8ed02d35ece5e8fe11ac887 Author: Andrea Corallo Date: Fri Dec 20 05:53:28 2019 +0100 introduce SUBRP_NATIVE_COMPILEDP diff --git a/src/alloc.c b/src/alloc.c index d990f53f7a..dba2c2df88 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -6566,7 +6566,7 @@ mark_object (Lisp_Object arg) case PVEC_SUBR: #ifdef HAVE_NATIVE_COMP - if (XSUBR (obj)->native_comp_u) + if (SUBRP_NATIVE_COMPILEDP (obj)) set_vector_marked (ptr); #endif break; @@ -6715,7 +6715,7 @@ survives_gc_p (Lisp_Object obj) case Lisp_Vectorlike: #ifdef HAVE_NATIVE_COMP survives_p = - (SUBRP (obj) && !XSUBR (obj)->native_comp_u) || + (SUBRP (obj) && !SUBRP_NATIVE_COMPILEDP (obj)) || vector_marked_p (XVECTOR (obj)); #else survives_p = SUBRP (obj) || vector_marked_p (XVECTOR (obj)); diff --git a/src/data.c b/src/data.c index 0a13569bc6..fd20ecce69 100644 --- a/src/data.c +++ b/src/data.c @@ -870,7 +870,7 @@ DEFUN ("subr-native-elisp-p", Fsubr_native_elisp_p, Ssubr_native_elisp_p, 1, 1, nil otherwise. */) (Lisp_Object object) { - return (SUBRP (object) && XSUBR (object)->native_comp_u) ? Qt : Qnil; + return SUBRP_NATIVE_COMPILEDP (object) ? Qt : Qnil; } #endif @@ -900,7 +900,7 @@ Value, if non-nil, is a list (interactive SPEC). */) if (SUBRP (fun)) { #ifdef HAVE_NATIVE_COMP - if (XSUBR (fun)->native_comp_u && XSUBR (fun)->native_intspec) + if (SUBRP_NATIVE_COMPILEDP (fun) && XSUBR (fun)->native_intspec) return XSUBR (fun)->native_intspec; #endif const char *spec = XSUBR (fun)->intspec; diff --git a/src/lisp.h b/src/lisp.h index bb441b181a..05d6ef0d22 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -2136,6 +2136,14 @@ enum char_table_specials = PSEUDOVECSIZE (struct Lisp_Sub_Char_Table, contents) - 1 }; +#ifdef HAVE_NATIVE_COMP +INLINE bool +SUBRP_NATIVE_COMPILEDP (Lisp_Object a) +{ + return SUBRP (a) && XSUBR (a)->native_comp_u; +} +#endif + /* Sanity-check pseudovector layout. */ verify (offsetof (struct Lisp_Char_Table, defalt) == header_size); verify (offsetof (struct Lisp_Char_Table, extras) commit f0671c60637e218a54f9f3ac8e5950d17884f50b Author: Andrea Corallo Date: Fri Dec 20 05:23:02 2019 +0100 make dynlib_close active code diff --git a/src/dynlib.c b/src/dynlib.c index 4919d5cc72..b3fd815e68 100644 --- a/src/dynlib.c +++ b/src/dynlib.c @@ -301,15 +301,11 @@ dynlib_error (void) return dlerror (); } -/* FIXME: Currently there is no way to unload a module, so this - function is never used. */ -#if false int dynlib_close (dynlib_handle_ptr h) { return dlclose (h) == 0; } -#endif #else commit 4496a3f5ba899c89e45cd478a22b25ddf77869ec Author: Andrea Corallo Date: Fri Dec 20 05:22:09 2019 +0100 initial compilation unit as object add diff --git a/src/alloc.c b/src/alloc.c index 5ff0d90791..d990f53f7a 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -3023,6 +3023,15 @@ cleanup_vector (struct Lisp_Vector *vector) if (uptr->finalizer) uptr->finalizer (uptr->p); } +#ifdef HAVE_NATIVE_COMP + else if (PSEUDOVECTOR_TYPEP (&vector->header, PVEC_NATIVE_COMP_UNIT)) + { + struct Lisp_Native_Compilation_Unit *cu = + PSEUDOVEC_STRUCT (vector, Lisp_Native_Compilation_Unit); + eassert (cu->handle); + dynlib_close (cu->handle); + } +#endif } /* Reclaim space used by unmarked vectors. */ @@ -6556,6 +6565,10 @@ mark_object (Lisp_Object arg) break; case PVEC_SUBR: +#ifdef HAVE_NATIVE_COMP + if (XSUBR (obj)->native_comp_u) + set_vector_marked (ptr); +#endif break; case PVEC_FREE: @@ -6700,7 +6713,13 @@ survives_gc_p (Lisp_Object obj) break; case Lisp_Vectorlike: +#ifdef HAVE_NATIVE_COMP + survives_p = + (SUBRP (obj) && !XSUBR (obj)->native_comp_u) || + vector_marked_p (XVECTOR (obj)); +#else survives_p = SUBRP (obj) || vector_marked_p (XVECTOR (obj)); +#endif break; case Lisp_Cons: diff --git a/src/comp.h b/src/comp.h new file mode 100644 index 0000000000..457b678699 --- /dev/null +++ b/src/comp.h @@ -0,0 +1,52 @@ +/* Elisp native compiler definitions +Copyright (C) 2012-2019 Free Software Foundation, Inc. + +This file is part of GNU Emacs. + +GNU Emacs is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +GNU Emacs is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Emacs. If not, see . */ + +#ifndef COMP_H +#define COMP_H + +#ifdef HAVE_NATIVE_COMP + +#include + +struct Lisp_Native_Compilation_Unit +{ + union vectorlike_header header; + /* Compilation unit file descriptor and handle. */ + int fd; + dynlib_handle_ptr handle; +}; + +INLINE bool +COMPILATIONP_UNITP (Lisp_Object a) +{ + return PSEUDOVECTORP (a, PVEC_NATIVE_COMP_UNIT); +} + +INLINE struct Lisp_Native_Compilation_Unit * +XCOMPILATION_UNIT (Lisp_Object a) +{ + eassert (COMPILATIONP_UNITP (a)); + return XUNTAG (a, Lisp_Vectorlike, struct Lisp_Native_Compilation_Unit); +} + +/* Defined in comp.c. */ +extern void syms_of_comp (void); +extern void fill_freloc (void); + +#endif +#endif diff --git a/src/lisp.h b/src/lisp.h index 04f729f182..bb441b181a 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -34,10 +34,6 @@ along with GNU Emacs. If not, see . */ #include #include -#ifdef HAVE_NATIVE_COMP -#include -#endif - INLINE_HEADER_BEGIN /* Define a TYPE constant ID as an externally visible name. Use like this: @@ -1097,6 +1093,7 @@ enum pvec_type PVEC_MUTEX, PVEC_CONDVAR, PVEC_MODULE_FUNCTION, + PVEC_NATIVE_COMP_UNIT, /* These should be last, check internal_equal to see why. */ PVEC_COMPILED, @@ -2068,10 +2065,7 @@ CHAR_TABLE_SET (Lisp_Object ct, int idx, Lisp_Object val) char_table_set (ct, idx, val); } -struct Native_Compilation_Unit -{ - dynlib_handle_ptr handle; -}; +#include "comp.h" /* This structure describes a built-in function. It is generated by the DEFUN macro only. @@ -2104,7 +2098,7 @@ struct Lisp_Subr Lisp_Object native_doc; }; #ifdef HAVE_NATIVE_COMP - struct Native_Compilation_Unit *native_comp_u;; + Lisp_Object native_comp_u;; #endif } GCALIGNED_STRUCT; union Aligned_Lisp_Subr @@ -4759,12 +4753,6 @@ extern bool profiler_memory_running; extern void malloc_probe (size_t); extern void syms_of_profiler (void); -#ifdef HAVE_NATIVE_COMP -/* Defined in comp.c. */ -extern void syms_of_comp (void); -extern void fill_freloc (void); -#endif /* HAVE_NATIVE_COMP */ - #ifdef DOS_NT /* Defined in msdos.c, w32.c. */ extern char *emacs_root_dir (void); diff --git a/src/print.c b/src/print.c index 425b0dc4ee..2e2c863ece 100644 --- a/src/print.c +++ b/src/print.c @@ -1825,7 +1825,16 @@ print_vectorlike (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag, } break; #endif - +#ifdef HAVE_NATIVE_COMP + case PVEC_NATIVE_COMP_UNIT: + { + print_c_string ("#", printcharfun); + int len = sprintf (buf, "%d", XCOMPILATION_UNIT (obj)->fd); + strout (buf, len, len, printcharfun); + printchar ('>', printcharfun); + } + break; +#endif default: emacs_abort (); } commit b3cbdfc86474932e4ef8d1237ed100a6f4f4c854 Author: Andrea Corallo Date: Thu Dec 19 11:06:38 2019 +0100 add basic compilation unit into structure diff --git a/src/comp.c b/src/comp.c index ce2a542e7c..79ece461a5 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3280,7 +3280,6 @@ DEFUN ("comp--register-subr", Fcomp__register_subr, Scomp__register_subr, x->s.symbol_name = xstrdup (SSDATA (Fsymbol_name (name))); x->s.native_intspec = intspec; x->s.native_doc = doc; - x->s.native_elisp = true; XSETPVECTYPE (&x->s, PVEC_SUBR); Lisp_Object tem; XSETSUBR (tem, &x->s); diff --git a/src/data.c b/src/data.c index 67613881d6..0a13569bc6 100644 --- a/src/data.c +++ b/src/data.c @@ -870,7 +870,7 @@ DEFUN ("subr-native-elisp-p", Fsubr_native_elisp_p, Ssubr_native_elisp_p, 1, 1, nil otherwise. */) (Lisp_Object object) { - return (SUBRP (object) && XSUBR (object)->native_elisp) ? Qt : Qnil; + return (SUBRP (object) && XSUBR (object)->native_comp_u) ? Qt : Qnil; } #endif @@ -900,7 +900,7 @@ Value, if non-nil, is a list (interactive SPEC). */) if (SUBRP (fun)) { #ifdef HAVE_NATIVE_COMP - if (XSUBR (fun)->native_elisp && XSUBR (fun)->native_intspec) + if (XSUBR (fun)->native_comp_u && XSUBR (fun)->native_intspec) return XSUBR (fun)->native_intspec; #endif const char *spec = XSUBR (fun)->intspec; diff --git a/src/lisp.h b/src/lisp.h index d0f7a9720c..04f729f182 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -34,6 +34,10 @@ along with GNU Emacs. If not, see . */ #include #include +#ifdef HAVE_NATIVE_COMP +#include +#endif + INLINE_HEADER_BEGIN /* Define a TYPE constant ID as an externally visible name. Use like this: @@ -2064,6 +2068,11 @@ CHAR_TABLE_SET (Lisp_Object ct, int idx, Lisp_Object val) char_table_set (ct, idx, val); } +struct Native_Compilation_Unit +{ + dynlib_handle_ptr handle; +}; + /* This structure describes a built-in function. It is generated by the DEFUN macro only. defsubr makes it into a Lisp object. */ @@ -2095,7 +2104,7 @@ struct Lisp_Subr Lisp_Object native_doc; }; #ifdef HAVE_NATIVE_COMP - bool native_elisp; + struct Native_Compilation_Unit *native_comp_u;; #endif } GCALIGNED_STRUCT; union Aligned_Lisp_Subr diff --git a/src/pdumper.c b/src/pdumper.c index 38b70146b4..24698d48b5 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -2938,7 +2938,7 @@ dump_subr (struct dump_context *ctx, const struct Lisp_Subr *subr) dump_field_emacs_ptr (ctx, &out, subr, &subr->intspec); DUMP_FIELD_COPY (&out, subr, doc); #ifdef HAVE_NATIVE_COMP - DUMP_FIELD_COPY (&out, subr, native_elisp); + dump_field_emacs_ptr (ctx, &out, subr, &subr->native_comp_u); #endif return dump_object_finish (ctx, &out, sizeof (out)); } commit a647a97320e72db275a05961ae09e487ee3063e2 Author: Andrea Corallo Date: Thu Dec 19 10:46:45 2019 +0100 better scratch slot support diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 7c4cfc95bf..60eb942066 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -257,9 +257,8 @@ structure.") (cl-defstruct (comp-mvar (:constructor make--comp-mvar)) "A meta-variable being a slot in the meta-stack." - (slot nil :type fixnum - :documentation "Slot number. --1 is a special value and indicates the scratch slot.") + (slot nil :type (or fixnum symbol) + :documentation "Slot number if a number or 'scratch' for scratch slot.") (id nil :type (or null number) :documentation "SSA number when in SSA form.") (const-vld nil :type boolean @@ -732,10 +731,10 @@ Return value is the fall through block name." else ;; Store the result of the comparison into the scratch slot before ;; emitting the conditional jump. - do (comp-emit (list 'set (make-comp-mvar :slot -1) + do (comp-emit (list 'set (make-comp-mvar :slot 'scratch) (comp-call test-func var m-test))) (comp-emit (list 'cond-jump - (make-comp-mvar :slot -1) + (make-comp-mvar :slot 'scratch) (make-comp-mvar :constant nil) target-name ff-bb-name)) do (unless last @@ -1180,7 +1179,7 @@ This will be called at load-time." (defun comp-limplify (lap-funcs) "Compute the LIMPLE ir for LAP-FUNCS. -Top level forms for the current context are rendered too." +Top-level forms for the current context are rendered too." (mapc #'comp-add-func-to-ctxt (mapcar #'comp-limplify-function lap-funcs)) (comp-add-func-to-ctxt (comp-limplify-top-level))) @@ -1342,7 +1341,7 @@ Top level forms for the current context are rendered too." ;; Return t if a SLOT-N was assigned within BB. (cl-loop for insn in (comp-block-insns bb) when (and (comp-assign-op-p (car insn)) - (= slot-n (comp-mvar-slot (cadr insn)))) + (eql slot-n (comp-mvar-slot (cadr insn)))) return t))) (cl-loop for i from 0 below (comp-func-frame-size comp-func) diff --git a/src/comp.c b/src/comp.c index 63c99b9833..ce2a542e7c 100644 --- a/src/comp.c +++ b/src/comp.c @@ -297,8 +297,9 @@ declare_block (Lisp_Object block_name) static gcc_jit_lvalue * get_slot (Lisp_Object mvar) { - EMACS_INT slot_n = XFIXNUM (CALL1I (comp-mvar-slot, mvar)); - if (slot_n == -1) + Lisp_Object mvar_slot = CALL1I (comp-mvar-slot, mvar); + + if (EQ (mvar_slot, Qscratch)) { if (!comp.scratch) comp.scratch = gcc_jit_function_new_local (comp.func, @@ -307,6 +308,7 @@ get_slot (Lisp_Object mvar) "scratch"); return comp.scratch; } + EMACS_INT slot_n = XFIXNUM (mvar_slot); gcc_jit_lvalue **frame = (CALL1I (comp-mvar-ref, mvar) || SPEED < 2) ? comp.frame : comp.f_frame; @@ -3366,6 +3368,7 @@ syms_of_comp (void) /* Others. */ DEFSYM (Qfixnum, "fixnum"); + DEFSYM (Qscratch, "scratch"); /* To be signaled by the compiler. */ DEFSYM (Qnative_compiler_error, "native-compiler-error"); commit ee4feb005ffe1d35ffc4d390d18b88ecfdebe2c2 Author: Andrea Corallo Date: Thu Dec 19 10:34:21 2019 +0100 fix some nits diff --git a/src/comp.c b/src/comp.c index 5f8fd35c64..63c99b9833 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1770,7 +1770,6 @@ declare_runtime_imported_funcs (void) static void emit_ctxt_code (void) { - comp.current_thread_ref = gcc_jit_lvalue_as_rvalue ( gcc_jit_context_new_global ( @@ -1804,9 +1803,9 @@ emit_ctxt_code (void) NULL, GCC_JIT_GLOBAL_EXPORTED, gcc_jit_context_new_array_type (comp.ctxt, - NULL, - comp.lisp_obj_type, - d_reloc_len), + NULL, + comp.lisp_obj_type, + d_reloc_len), DATA_RELOC_SYM)); emit_static_object (TEXT_DATA_RELOC_SYM, d_reloc); @@ -2726,8 +2725,8 @@ declare_function (Lisp_Object func) for (ptrdiff_t i = 0; i < max_args; i++) type[i] = comp.lisp_obj_type; - gcc_jit_param **param = SAFE_ALLOCA (max_args *sizeof (*param)); - for (int i = max_args - 1; i >= 0; i--) + gcc_jit_param **param = SAFE_ALLOCA (max_args * sizeof (*param)); + for (int i = 0; i < max_args; ++i) param[i] = gcc_jit_context_new_param (comp.ctxt, NULL, type[i], commit 88671e638b308886a9d6b5a590ee1aee56746d7b Author: Andrea Corallo Date: Mon Dec 16 23:33:45 2019 +0100 make use of ARRAYELTS macro where possible diff --git a/src/comp.c b/src/comp.c index 3324d9f921..5f8fd35c64 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1910,8 +1910,7 @@ define_lisp_cons (void) gcc_jit_context_new_union_type (comp.ctxt, NULL, "comp_cdr_u", - sizeof (cdr_u_fields) - / sizeof (*cdr_u_fields), + ARRAYELTS (cdr_u_fields), cdr_u_fields); comp.lisp_cons_u_s_car = gcc_jit_context_new_field (comp.ctxt, @@ -1930,8 +1929,7 @@ define_lisp_cons (void) gcc_jit_context_new_struct_type (comp.ctxt, NULL, "comp_cons_s", - sizeof (cons_s_fields) - / sizeof (*cons_s_fields), + ARRAYELTS (cons_s_fields), cons_s_fields); comp.lisp_cons_u_s = gcc_jit_context_new_field (comp.ctxt, @@ -1954,8 +1952,7 @@ define_lisp_cons (void) gcc_jit_context_new_union_type (comp.ctxt, NULL, "comp_cons_u", - sizeof (cons_u_fields) - / sizeof (*cons_u_fields), + ARRAYELTS (cons_u_fields), cons_u_fields); comp.lisp_cons_u = @@ -2046,7 +2043,7 @@ define_handler_struct (void) "pad2") }; gcc_jit_struct_set_fields (comp.handler_s, NULL, - sizeof (fields) / sizeof (*fields), + ARRAYELTS (fields), fields); } @@ -2090,7 +2087,7 @@ define_thread_state_struct (void) gcc_jit_context_new_struct_type (comp.ctxt, NULL, "comp_thread_state", - sizeof (fields) / sizeof (*fields), + ARRAYELTS (fields), fields); comp.thread_state_ptr_type = gcc_jit_type_get_pointer (gcc_jit_struct_as_type (comp.thread_state_s)); @@ -2191,8 +2188,7 @@ define_cast_union (void) gcc_jit_context_new_union_type (comp.ctxt, NULL, "cast_union", - sizeof (cast_union_fields) - / sizeof (*cast_union_fields), + ARRAYELTS (cast_union_fields), cast_union_fields); } @@ -2976,12 +2972,12 @@ DEFUN ("comp--init-ctxt", Fcomp__init_ctxt, Scomp__init_ctxt, gcc_jit_field *lisp_obj_fields[] = { comp.lisp_obj_as_ptr, comp.lisp_obj_as_num }; - comp.lisp_obj_type = gcc_jit_context_new_union_type (comp.ctxt, - NULL, - "comp_Lisp_Object", - sizeof (lisp_obj_fields) - / sizeof (*lisp_obj_fields), - lisp_obj_fields); + comp.lisp_obj_type = + gcc_jit_context_new_union_type (comp.ctxt, + NULL, + "comp_Lisp_Object", + ARRAYELTS (lisp_obj_fields), + lisp_obj_fields); comp.lisp_obj_ptr_type = gcc_jit_type_get_pointer (comp.lisp_obj_type); comp.most_positive_fixnum = @@ -3274,7 +3270,7 @@ DEFUN ("comp--register-subr", Fcomp__register_subr, Scomp__register_subr, eassert (func); /* FIXME add gc support, now just leaking. */ - union Aligned_Lisp_Subr *x = xmalloc (sizeof (union Aligned_Lisp_Subr)); + union Aligned_Lisp_Subr *x = xmalloc (sizeof (*x)); x->s.header.size = PVEC_SUBR << PSEUDOVECTOR_AREA_BITS; x->s.function.a0 = func; commit a10405386f83333184c94a0a194b404e4273e2d0 Author: Andrea Corallo Date: Sun Dec 15 18:26:25 2019 +0100 malloc instead of static alloc into emit_ctxt_code make it good to be reentrant diff --git a/src/comp.c b/src/comp.c index 288aa6ccc4..3324d9f921 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1813,13 +1813,13 @@ emit_ctxt_code (void) /* Functions imported from Lisp code. */ - static gcc_jit_field *fields[F_RELOC_MAX_SIZE]; + gcc_jit_field **fields = xmalloc (freloc.size * sizeof (*fields)); ptrdiff_t n_frelocs = 0; Lisp_Object f_runtime = declare_runtime_imported_funcs (); FOR_EACH_TAIL (f_runtime) { Lisp_Object el = XCAR (f_runtime); - eassert (n_frelocs < ARRAYELTS (fields)); + eassert (n_frelocs < freloc.size); fields[n_frelocs++] = xmint_pointer (XCDR (el)); } @@ -1828,7 +1828,7 @@ emit_ctxt_code (void) { struct Lisp_Subr *subr = XSUBR (XCAR (subr_l)); Lisp_Object subr_sym = intern_c_string (subr->symbol_name); - eassert (n_frelocs < ARRAYELTS (fields)); + eassert (n_frelocs < freloc.size); fields[n_frelocs++] = declare_imported_func (subr_sym, comp.lisp_obj_type, subr->max_args, NULL); } @@ -1845,6 +1845,8 @@ emit_ctxt_code (void) GCC_JIT_GLOBAL_EXPORTED, gcc_jit_type_get_pointer (gcc_jit_struct_as_type (f_reloc_struct)), IMPORTED_FUNC_LINK_TABLE); + + xfree (fields); } commit d0fcb15fa9858eb600b0a8f35ebbdf5aadc2cd7c Author: Andrea Corallo Date: Sun Dec 15 16:50:37 2019 +0100 fix comp--register-subr diff --git a/src/comp.c b/src/comp.c index 5a00139668..288aa6ccc4 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3282,7 +3282,10 @@ DEFUN ("comp--register-subr", Fcomp__register_subr, Scomp__register_subr, x->s.native_intspec = intspec; x->s.native_doc = doc; x->s.native_elisp = true; - defsubr (x); + XSETPVECTYPE (&x->s, PVEC_SUBR); + Lisp_Object tem; + XSETSUBR (tem, &x->s); + set_symbol_function (name, tem); LOADHIST_ATTACH (Fcons (Qdefun, name)); commit d0173ecd0ce8c2ac458cd84c25216f59f3fc9889 Author: Andrea Corallo Date: Sun Dec 15 15:43:04 2019 +0100 remove advice dependency diff --git a/src/comp.c b/src/comp.c index ea37b89f84..5a00139668 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3053,8 +3053,6 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, { CHECK_STRING (ctxtname); - Frequire (Qadvice, Qnil, Qnil); - gcc_jit_context_set_int_option (comp.ctxt, GCC_JIT_INT_OPTION_OPTIMIZATION_LEVEL, SPEED); @@ -3302,8 +3300,6 @@ DEFUN ("native-elisp-load", Fnative_elisp_load, Snative_elisp_load, 1, 1, 0, xsignal2 (Qnative_lisp_load_failed, file, build_string ("Empty relocation table")); - Frequire (Qadvice, Qnil, Qnil); - dynlib_handle_ptr handle = dynlib_open (SSDATA (file)); load_handle_stack = Fcons (make_mint_ptr (handle), load_handle_stack); if (!handle) @@ -3370,11 +3366,8 @@ syms_of_comp (void) /* Others. */ DEFSYM (Qfixnum, "fixnum"); - DEFSYM (Qadvice, "advice"); - - /* To be signaled. */ - /* By the compiler. */ + /* To be signaled by the compiler. */ DEFSYM (Qnative_compiler_error, "native-compiler-error"); Fput (Qnative_compiler_error, Qerror_conditions, pure_list (Qnative_compiler_error, Qerror)); commit ac08a7f26c53d65df7d9c2a5d76300a6a1a8106b Author: Andrea Corallo Date: Sun Dec 15 15:31:03 2019 +0100 clean-up old function relocation code diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 0f0a90c82f..7c4cfc95bf 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -153,11 +153,7 @@ This is to build the prev field.") (data-relocs-l () :type list :documentation "Constant objects used by functions.") (data-relocs-idx (make-hash-table :test #'equal) :type hash-table - :documentation "Obj -> position into data-relocs.") - (func-relocs-l () :type list - :documentation "Native functions imported.") - (func-relocs-idx (make-hash-table :test #'equal) :type hash-table - :documentation "Obj -> position into func-relocs.")) + :documentation "Obj -> position into data-relocs.")) (cl-defstruct comp-args-base (min nil :type number @@ -309,15 +305,6 @@ The corresponding index is returned." (push obj (comp-ctxt-data-relocs-l comp-ctxt)) (puthash obj (hash-table-count data-relocs-idx) data-relocs-idx)))) -(defun comp-add-subr-to-relocs (subr-name) - "Keep track of SUBR-NAME into the ctxt relocations. -The corresponding index is returned." - (let ((func-relocs-idx (comp-ctxt-func-relocs-idx comp-ctxt))) - (if-let ((idx (gethash subr-name func-relocs-idx))) - idx - (push subr-name (comp-ctxt-func-relocs-l comp-ctxt)) - (puthash subr-name (hash-table-count func-relocs-idx) func-relocs-idx)))) - (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." @@ -569,16 +556,14 @@ The basic block is returned regardless it was already declared or not." (car (push (make--comp-block lap-addr sp (comp-new-block-sym)) (comp-limplify-pending-blocks comp-pass)))))) -(defun comp-call (func &rest args) +(defsubst comp-call (func &rest args) "Emit a call for function FUNC with ARGS." - (comp-add-subr-to-relocs func) `(call ,func ,@args)) (defun comp-callref (func nargs stack-off) "Emit a call using narg abi for FUNC. NARGS is the number of arguments. STACK-OFF is the index of the first slot frame involved." - (comp-add-subr-to-relocs func) `(callref ,func ,@(cl-loop repeat nargs for sp from stack-off collect (comp-slot-n sp)))) @@ -1644,7 +1629,6 @@ Return t if something was changed." (args (if (eq call-type 'callref) args (fill-args args maxarg)))) - (comp-add-subr-to-relocs callee) `(,call-type ,callee ,@(clean-args-ref args)))) ;; Intra compilation unit procedure call optimization. ;; Attention speed 3 triggers that for non self calls too!! diff --git a/src/comp.c b/src/comp.c index a233187ccd..ea37b89f84 100644 --- a/src/comp.c +++ b/src/comp.c @@ -38,9 +38,8 @@ along with GNU Emacs. If not, see . */ #define CURRENT_THREAD_RELOC_SYM "current_thread_reloc" #define PURE_RELOC_SYM "pure_reloc" #define DATA_RELOC_SYM "d_reloc" -#define IMPORTED_FUNC_RELOC_SYM "f_reloc" +#define IMPORTED_FUNC_LINK_TABLE "freloc_link_table" #define TEXT_DATA_RELOC_SYM "text_data_reloc" -#define TEXT_IMPORTED_FUNC_RELOC_SYM "text_imported_funcs" #define SPEED XFIXNUM (Fsymbol_value (Qcomp_speed)) #define COMP_DEBUG XFIXNUM (Fsymbol_value (Qcomp_debug)) @@ -232,21 +231,6 @@ bcall0 (Lisp_Object f) Ffuncall (1, &f); } -/* Try to return the original subr from `symbol' even if this was advised. */ -static Lisp_Object -symbol_subr (Lisp_Object symbol) -{ - Lisp_Object maybe_subr = Fsymbol_function (symbol); - - if (SUBRP (maybe_subr)) - return maybe_subr; - - if (!NILP (CALL1I (advice--p, maybe_subr))) - maybe_subr = CALL1I (ad-get-orig-definition, symbol); - - return SUBRP (maybe_subr) ? maybe_subr : Qnil; -} - static gcc_jit_field * type_to_cast_field (gcc_jit_type *type) { @@ -430,9 +414,11 @@ emit_call (Lisp_Object subr_sym, gcc_jit_type *ret_type, ptrdiff_t nargs, else { gcc_jit_lvalue *f_ptr = - gcc_jit_lvalue_access_field (comp.func_relocs, - NULL, - (gcc_jit_field *) xmint_pointer (func)); + gcc_jit_rvalue_dereference_field ( + gcc_jit_lvalue_as_rvalue (comp.func_relocs), + NULL, + (gcc_jit_field *) xmint_pointer (func)); + if (!f_ptr) xsignal2 (Qnative_ice, build_string ("missing function relocation"), @@ -1726,15 +1712,8 @@ declare_runtime_imported_data (void) static Lisp_Object declare_runtime_imported_funcs (void) { - /* For subr imported by the runtime we rely on the standard mechanism in place - for functions imported by lisp code. */ - CALL1I (comp-add-subr-to-relocs, intern_c_string ("1+")); - CALL1I (comp-add-subr-to-relocs, intern_c_string ("1-")); - CALL1I (comp-add-subr-to-relocs, Qplus); - CALL1I (comp-add-subr-to-relocs, Qminus); - CALL1I (comp-add-subr-to-relocs, Qlist); - Lisp_Object field_list = Qnil; + #define ADD_IMPORTED(f_name, ret_type, nargs, args) \ { \ Lisp_Object name = intern_c_string (STR (f_name)); \ @@ -1864,8 +1843,8 @@ emit_ctxt_code (void) comp.ctxt, NULL, GCC_JIT_GLOBAL_EXPORTED, - gcc_jit_struct_as_type (f_reloc_struct), - IMPORTED_FUNC_RELOC_SYM); + gcc_jit_type_get_pointer (gcc_jit_struct_as_type (f_reloc_struct)), + IMPORTED_FUNC_LINK_TABLE); } @@ -3248,13 +3227,13 @@ load_comp_unit (dynlib_handle_ptr handle, Lisp_Object file) dynlib_sym (handle, CURRENT_THREAD_RELOC_SYM); EMACS_INT ***pure_reloc = dynlib_sym (handle, PURE_RELOC_SYM); Lisp_Object *data_relocs = dynlib_sym (handle, DATA_RELOC_SYM); - Lisp_Object (**f_relocs)(void) = dynlib_sym (handle, IMPORTED_FUNC_RELOC_SYM); + void **freloc_link_table = dynlib_sym (handle, IMPORTED_FUNC_LINK_TABLE); void (*top_level_run)(void) = dynlib_sym (handle, "top_level_run"); if (!(current_thread_reloc && pure_reloc && data_relocs - && f_relocs + && freloc_link_table && top_level_run)) xsignal1 (Qnative_lisp_file_inconsistent, file); @@ -3272,51 +3251,7 @@ load_comp_unit (dynlib_handle_ptr handle, Lisp_Object file) } /* Imported functions. */ - Lisp_Object f_vec = - load_static_obj (handle, TEXT_IMPORTED_FUNC_RELOC_SYM); - EMACS_INT f_vec_len = XFIXNUM (Flength (f_vec)); - for (EMACS_INT i = 0; i < f_vec_len; i++) - { - Lisp_Object f_sym = AREF (f_vec, i); - char *f_str = SSDATA (SYMBOL_NAME (f_sym)); - Lisp_Object subr = Fsymbol_function (f_sym); - if (!NILP (subr)) - { - subr = symbol_subr (f_sym); - if (NILP (subr)) - /* FIXME: This is not robust in case of primitive - redefinition. */ - xsignal2 (Qnative_lisp_wrong_reloc, f_sym, file); - - f_relocs[i] = XSUBR (subr)->function.a0; - } - else if (!strcmp (f_str, "wrong_type_argument")) - f_relocs[i] = (void *) wrong_type_argument; - else if (!strcmp (f_str, "helper_PSEUDOVECTOR_TYPEP_XUNTAG")) - f_relocs[i] = (void *) helper_PSEUDOVECTOR_TYPEP_XUNTAG; - else if (!strcmp (f_str, "pure_write_error")) - f_relocs[i] = (void *) pure_write_error; - else if (!strcmp (f_str, "push_handler")) - f_relocs[i] = (void *) push_handler; - else if (!strcmp (f_str, STR (SETJMP_NAME))) - f_relocs[i] = (void *) SETJMP; - else if (!strcmp (f_str, "record_unwind_protect_excursion")) - f_relocs[i] = (void *) record_unwind_protect_excursion; - else if (!strcmp (f_str, "helper_unbind_n")) - f_relocs[i] = (void *) helper_unbind_n; - else if (!strcmp (f_str, "helper_save_restriction")) - f_relocs[i] = (void *) helper_save_restriction; - else if (!strcmp (f_str, "record_unwind_current_buffer")) - f_relocs[i] = (void *) record_unwind_current_buffer; - else if (!strcmp (f_str, "set_internal")) - f_relocs[i] = (void *) set_internal; - else if (!strcmp (f_str, "helper_unwind_protect")) - f_relocs[i] = (void *) helper_unwind_protect; - else if (!strcmp (f_str, "specbind")) - f_relocs[i] = (void *) specbind; - else - xsignal2 (Qnative_lisp_wrong_reloc, f_sym, file); - } + *freloc_link_table = freloc.link_table; /* Executing this will perform all the expected environment modification. */ top_level_run (); commit 694ece772220346aef12520bc66ca401d08809bb Author: Andrea Corallo Date: Sat Dec 14 09:28:12 2019 +0100 reworking relocation mechanism to use one single table diff --git a/src/comp.c b/src/comp.c index 70b423aa97..a233187ccd 100644 --- a/src/comp.c +++ b/src/comp.c @@ -70,6 +70,16 @@ along with GNU Emacs. If not, see . */ #endif #define SETJMP_NAME SETJMP +/* Max number function importable by native compiled code. */ +#define F_RELOC_MAX_SIZE 1500 + +typedef struct { + void *link_table[F_RELOC_MAX_SIZE]; + ptrdiff_t size; +} f_reloc_t; + +static f_reloc_t freloc; + /* C side of the compiler context. */ typedef struct { @@ -157,7 +167,7 @@ typedef struct { gcc_jit_function *check_impure; Lisp_Object func_blocks_h; /* blk_name -> gcc_block. */ Lisp_Object exported_funcs_h; /* subr_name -> gcc_jit_function *. */ - Lisp_Object imported_funcs_h; /* subr_name -> reloc_field. */ + Lisp_Object imported_funcs_h; /* subr_name -> gcc_jit_field *reloc_field. */ Lisp_Object emitter_dispatcher; gcc_jit_rvalue *data_relocs; /* Synthesized struct holding data relocs. */ gcc_jit_lvalue *func_relocs; /* Synthesized struct holding func relocs. */ @@ -184,6 +194,20 @@ Lisp_Object helper_unbind_n (Lisp_Object n); void helper_save_restriction (void); bool helper_PSEUDOVECTOR_TYPEP_XUNTAG (Lisp_Object a, enum pvec_type code); +void *helper_link_table[] = + { wrong_type_argument, + helper_PSEUDOVECTOR_TYPEP_XUNTAG, + pure_write_error, + push_handler, + SETJMP_NAME, + record_unwind_protect_excursion, + helper_unbind_n, + helper_save_restriction, + record_unwind_current_buffer, + set_internal, + helper_unwind_protect, + specbind }; + static char * ATTRIBUTE_FORMAT_PRINTF (1, 2) format_string (const char *format, ...) @@ -1758,7 +1782,7 @@ declare_runtime_imported_funcs (void) #undef ADD_IMPORTED - return field_list; + return Freverse (field_list); } /* @@ -1767,7 +1791,6 @@ declare_runtime_imported_funcs (void) static void emit_ctxt_code (void) { - USE_SAFE_ALLOCA; comp.current_thread_ref = gcc_jit_lvalue_as_rvalue ( @@ -1809,56 +1832,32 @@ emit_ctxt_code (void) emit_static_object (TEXT_DATA_RELOC_SYM, d_reloc); - /* Imported functions from non Lisp code. */ - Lisp_Object f_runtime = declare_runtime_imported_funcs (); - EMACS_INT f_reloc_len = XFIXNUM (Flength (f_runtime)); - - /* Imported subrs. */ - Lisp_Object f_subr = CALL1I (comp-ctxt-func-relocs-l, Vcomp_ctxt); - f_reloc_len += XFIXNUM (Flength (f_subr)); - - gcc_jit_field **fields = SAFE_ALLOCA (f_reloc_len * sizeof (*fields)); - Lisp_Object f_reloc_list = Qnil; - int n_frelocs = 0; + /* Functions imported from Lisp code. */ + static gcc_jit_field *fields[F_RELOC_MAX_SIZE]; + ptrdiff_t n_frelocs = 0; + Lisp_Object f_runtime = declare_runtime_imported_funcs (); FOR_EACH_TAIL (f_runtime) { Lisp_Object el = XCAR (f_runtime); + eassert (n_frelocs < ARRAYELTS (fields)); fields[n_frelocs++] = xmint_pointer (XCDR (el)); - f_reloc_list = Fcons (XCAR (el), f_reloc_list); } - FOR_EACH_TAIL (f_subr) + Lisp_Object subr_l = Vsubr_list; + FOR_EACH_TAIL (subr_l) { - Lisp_Object subr_sym = XCAR (f_subr); - Lisp_Object subr = symbol_subr (subr_sym); - /* Ignore inliners. This are not real functions to be imported. */ - if (SUBRP (subr)) - { - Lisp_Object maxarg = XCDR (Fsubr_arity (subr)); - gcc_jit_field *field = - declare_imported_func (subr_sym, comp.lisp_obj_type, - FIXNUMP (maxarg) ? XFIXNUM (maxarg) : - EQ (maxarg, Qmany) ? MANY : UNEVALLED, - NULL); - fields[n_frelocs++] = field; - f_reloc_list = Fcons (subr_sym, f_reloc_list); - } + struct Lisp_Subr *subr = XSUBR (XCAR (subr_l)); + Lisp_Object subr_sym = intern_c_string (subr->symbol_name); + eassert (n_frelocs < ARRAYELTS (fields)); + fields[n_frelocs++] = declare_imported_func (subr_sym, comp.lisp_obj_type, + subr->max_args, NULL); } - Lisp_Object f_reloc_vec = make_vector (n_frelocs, Qnil); - f_reloc_list = Fnreverse (f_reloc_list); - ptrdiff_t i = 0; - FOR_EACH_TAIL (f_reloc_list) - { - ASET (f_reloc_vec, i++, XCAR (f_reloc_list)); - } - emit_static_object (TEXT_IMPORTED_FUNC_RELOC_SYM, f_reloc_vec); - gcc_jit_struct *f_reloc_struct = gcc_jit_context_new_struct_type (comp.ctxt, NULL, - "function_reloc_struct", + "freloc_link_table", n_frelocs, fields); comp.func_relocs = gcc_jit_context_new_global ( @@ -1867,8 +1866,6 @@ emit_ctxt_code (void) GCC_JIT_GLOBAL_EXPORTED, gcc_jit_struct_as_type (f_reloc_struct), IMPORTED_FUNC_RELOC_SYM); - - SAFE_FREE (); } @@ -3038,8 +3035,8 @@ DEFUN ("comp--init-ctxt", Fcomp__init_ctxt, Scomp__init_ctxt, comp.exported_funcs_h = CALLN (Fmake_hash_table); /* - Always reinitialize this cause old function definitions are garbage collected - by libgccjit when the ctxt is released. + Always reinitialize this cause old function definitions are garbage + collected by libgccjit when the ctxt is released. */ comp.imported_funcs_h = CALLN (Fmake_hash_table); @@ -3140,6 +3137,29 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, } +void +fill_freloc (void) +{ + if (ARRAYELTS (helper_link_table) > F_RELOC_MAX_SIZE) + goto overflow; + memcpy (freloc.link_table, helper_link_table, sizeof (freloc.link_table)); + freloc.size = ARRAYELTS (helper_link_table); + + Lisp_Object subr_l = Vsubr_list; + FOR_EACH_TAIL (subr_l) + { + if (freloc.size == F_RELOC_MAX_SIZE) + goto overflow; + struct Lisp_Subr *subr = XSUBR (XCAR (subr_l)); + freloc.link_table[freloc.size] = subr->function.a0; + freloc.size++; + } + return; + + overflow: + fatal ("Overflowing function relocation table, increase F_RELOC_MAX_SIZE"); +} + /******************************************************************************/ /* Helper functions called from the run-time. */ /* These can't be statics till shared mechanism is used to solve relocations. */ @@ -3343,6 +3363,10 @@ DEFUN ("native-elisp-load", Fnative_elisp_load, Snative_elisp_load, 1, 1, 0, { CHECK_STRING (file); + if (!freloc.link_table[0]) + xsignal2 (Qnative_lisp_load_failed, file, + build_string ("Empty relocation table")); + Frequire (Qadvice, Qnil, Qnil); dynlib_handle_ptr handle = dynlib_open (SSDATA (file)); @@ -3472,6 +3496,10 @@ syms_of_comp (void) doc: /* The compiler context. */); Vcomp_ctxt = Qnil; + /* FIXME should be initialized but not here... */ + DEFVAR_LISP ("comp-subr-list", Vsubr_list, + doc: /* List of all defined subrs. */); + /* Load mechanism. */ staticpro (&Vnative_elisp_refs_hash); Vnative_elisp_refs_hash diff --git a/src/emacs.c b/src/emacs.c index 90ab7ac1e8..0798e0702f 100644 --- a/src/emacs.c +++ b/src/emacs.c @@ -2050,6 +2050,10 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem moncontrol (0); #endif +#ifdef HAVE_NATIVE_COMP + fill_freloc (); +#endif + initialized = true; if (dump_mode) diff --git a/src/lisp.h b/src/lisp.h index 25319047a6..d0f7a9720c 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -4750,9 +4750,10 @@ extern bool profiler_memory_running; extern void malloc_probe (size_t); extern void syms_of_profiler (void); -/* Defined in comp.c. */ #ifdef HAVE_NATIVE_COMP +/* Defined in comp.c. */ extern void syms_of_comp (void); +extern void fill_freloc (void); #endif /* HAVE_NATIVE_COMP */ #ifdef DOS_NT diff --git a/src/lread.c b/src/lread.c index f280dad97c..1ba04835aa 100644 --- a/src/lread.c +++ b/src/lread.c @@ -4465,6 +4465,9 @@ defsubr (union Aligned_Lisp_Subr *aname) XSETPVECTYPE (sname, PVEC_SUBR); XSETSUBR (tem, sname); set_symbol_function (sym, tem); +#ifdef HAVE_NATIVE_COMP + Vsubr_list = Fcons (tem, Vsubr_list); +#endif /* HAVE_NATIVE_COMP */ } #ifdef NOTDEF /* Use fset in subr.el now! */ commit 740462da6153b111a8196b003791a55c7f7fa878 Author: Andrea Corallo Date: Sun Dec 15 15:06:07 2019 +0100 remove ifdef where unnecessary and add where they are diff --git a/src/lisp.h b/src/lisp.h index 56aa7b151e..25319047a6 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -2088,17 +2088,15 @@ struct Lisp_Subr const char *symbol_name; union { const char *intspec; -#ifdef HAVE_NATIVE_COMP Lisp_Object native_intspec; -#endif }; union { EMACS_INT doc; -#ifdef HAVE_NATIVE_COMP Lisp_Object native_doc; -#endif }; +#ifdef HAVE_NATIVE_COMP bool native_elisp; +#endif } GCALIGNED_STRUCT; union Aligned_Lisp_Subr { commit 8234a62e6fb9f706f410a96e2ce9877c19e44a20 Author: Andrea Corallo Date: Sun Dec 15 09:35:50 2019 +0100 stringify within macro ADD_IMPORTED diff --git a/src/comp.c b/src/comp.c index 42f3b5d04f..70b423aa97 100644 --- a/src/comp.c +++ b/src/comp.c @@ -68,7 +68,7 @@ along with GNU Emacs. If not, see . */ #else #define SETJMP setjmp #endif -#define SETJMP_NAME STR (SETJMP) +#define SETJMP_NAME SETJMP /* C side of the compiler context. */ @@ -1199,7 +1199,7 @@ emit_limple_push_handler (gcc_jit_rvalue *handler, gcc_jit_rvalue *handler_type, gcc_jit_rvalue *res; res = - emit_call (intern_c_string (SETJMP_NAME), comp.int_type, 1, args, false); + emit_call (intern_c_string (STR (SETJMP_NAME)), comp.int_type, 1, args, false); emit_cond_jump (res, handler_bb, guarded_bb); } @@ -1713,7 +1713,7 @@ declare_runtime_imported_funcs (void) Lisp_Object field_list = Qnil; #define ADD_IMPORTED(f_name, ret_type, nargs, args) \ { \ - Lisp_Object name = intern_c_string (f_name); \ + Lisp_Object name = intern_c_string (STR (f_name)); \ Lisp_Object field = \ make_mint_ptr (declare_imported_func (name, ret_type, nargs, args)); \ Lisp_Object el = Fcons (name, field); \ @@ -1722,39 +1722,39 @@ declare_runtime_imported_funcs (void) gcc_jit_type *args[4]; - ADD_IMPORTED ("wrong_type_argument", comp.void_type, 2, NULL); + ADD_IMPORTED (wrong_type_argument, comp.void_type, 2, NULL); args[0] = comp.lisp_obj_type; args[1] = comp.int_type; - ADD_IMPORTED ("helper_PSEUDOVECTOR_TYPEP_XUNTAG", comp.bool_type, 2, args); + ADD_IMPORTED (helper_PSEUDOVECTOR_TYPEP_XUNTAG, comp.bool_type, 2, args); - ADD_IMPORTED ("pure_write_error", comp.void_type, 1, NULL); + ADD_IMPORTED (pure_write_error, comp.void_type, 1, NULL); args[0] = comp.lisp_obj_type; args[1] = comp.int_type; - ADD_IMPORTED ("push_handler", comp.handler_ptr_type, 2, args); + ADD_IMPORTED (push_handler, comp.handler_ptr_type, 2, args); args[0] = gcc_jit_type_get_pointer (gcc_jit_struct_as_type (comp.jmp_buf_s)); ADD_IMPORTED (SETJMP_NAME, comp.int_type, 1, args); - ADD_IMPORTED ("record_unwind_protect_excursion", comp.void_type, 0, NULL); + ADD_IMPORTED (record_unwind_protect_excursion, comp.void_type, 0, NULL); args[0] = comp.lisp_obj_type; - ADD_IMPORTED ("helper_unbind_n", comp.lisp_obj_type, 1, args); + ADD_IMPORTED (helper_unbind_n, comp.lisp_obj_type, 1, args); - ADD_IMPORTED ("helper_save_restriction", comp.void_type, 0, NULL); + ADD_IMPORTED (helper_save_restriction, comp.void_type, 0, NULL); - ADD_IMPORTED ("record_unwind_current_buffer", comp.void_type, 0, NULL); + ADD_IMPORTED (record_unwind_current_buffer, comp.void_type, 0, NULL); args[0] = args[1] = args[2] = comp.lisp_obj_type; args[3] = comp.int_type; - ADD_IMPORTED ("set_internal", comp.void_type, 4, args); + ADD_IMPORTED (set_internal, comp.void_type, 4, args); args[0] = comp.lisp_obj_type; - ADD_IMPORTED ("helper_unwind_protect", comp.void_type, 1, args); + ADD_IMPORTED (helper_unwind_protect, comp.void_type, 1, args); args[0] = args[1] = comp.lisp_obj_type; - ADD_IMPORTED ("specbind", comp.void_type, 2, args); + ADD_IMPORTED (specbind, comp.void_type, 2, args); #undef ADD_IMPORTED @@ -3278,7 +3278,7 @@ load_comp_unit (dynlib_handle_ptr handle, Lisp_Object file) f_relocs[i] = (void *) pure_write_error; else if (!strcmp (f_str, "push_handler")) f_relocs[i] = (void *) push_handler; - else if (!strcmp (f_str, SETJMP_NAME)) + else if (!strcmp (f_str, STR (SETJMP_NAME))) f_relocs[i] = (void *) SETJMP; else if (!strcmp (f_str, "record_unwind_protect_excursion")) f_relocs[i] = (void *) record_unwind_protect_excursion; commit 26ce5664ae431ec141e852a4183844d83c3f8856 Author: Andrea Corallo Date: Sun Dec 15 08:58:17 2019 +0100 use safe alloca in declare_imported_func diff --git a/src/comp.c b/src/comp.c index 6722d7fb80..42f3b5d04f 100644 --- a/src/comp.c +++ b/src/comp.c @@ -330,6 +330,7 @@ static gcc_jit_field * declare_imported_func (Lisp_Object subr_sym, gcc_jit_type *ret_type, int nargs, gcc_jit_type **types) { + USE_SAFE_ALLOCA; /* Don't want to declare the same function two times. */ if (!NILP (Fgethash (subr_sym, comp.imported_funcs_h, Qnil))) xsignal2 (Qnative_ice, @@ -339,19 +340,19 @@ declare_imported_func (Lisp_Object subr_sym, gcc_jit_type *ret_type, if (nargs == MANY) { nargs = 2; - types = alloca (nargs * sizeof (* types)); + types = SAFE_ALLOCA (nargs * sizeof (* types)); types[0] = comp.ptrdiff_type; types[1] = comp.lisp_obj_ptr_type; } else if (nargs == UNEVALLED) { nargs = 1; - types = alloca (nargs * sizeof (* types)); + types = SAFE_ALLOCA (nargs * sizeof (* types)); types[0] = comp.lisp_obj_type; } else if (!types) { - types = alloca (nargs * sizeof (* types)); + types = SAFE_ALLOCA (nargs * sizeof (* types)); for (ptrdiff_t i = 0; i < nargs; i++) types[i] = comp.lisp_obj_type; } @@ -375,6 +376,7 @@ declare_imported_func (Lisp_Object subr_sym, gcc_jit_type *ret_type, SSDATA (f_ptr_name)); Fputhash (subr_sym, make_mint_ptr (field), comp.imported_funcs_h); + SAFE_FREE (); return field; } commit 54e0b112d3a91c86230bc4329e00ae8f2faa05e8 Author: Andrea Corallo Date: Sat Dec 14 08:57:17 2019 +0100 style nit diff --git a/src/comp.c b/src/comp.c index a15bedf41a..6722d7fb80 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3302,8 +3302,7 @@ load_comp_unit (dynlib_handle_ptr handle, Lisp_Object file) return; } -DEFUN ("comp--register-subr", Fcomp__register_subr, - Scomp__register_subr, +DEFUN ("comp--register-subr", Fcomp__register_subr, Scomp__register_subr, 6, 6, 0, doc: /* This gets called by top_level_run during load phase to register each exported subr. */) commit 6c9acd13d0d2aa181d21bf78d6530b3399520533 Author: Andrea Corallo Date: Sun Dec 8 20:52:34 2019 +0100 single function native compilation doc + interactive support + tests diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index ffd4985301..0f0a90c82f 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -420,7 +420,9 @@ Put PREFIX in front of it." "Byte compile FUNCTION-NAME spilling data from the byte compiler." (let* ((f (symbol-function function-name)) (func (make-comp-func :name function-name - :c-name (comp-c-func-name function-name"F")))) + :c-name (comp-c-func-name function-name"F") + :doc (documentation f) + :int-spec (interactive-form f)))) (when (byte-code-function-p f) (signal 'native-compiler-error "can't native compile an already bytecompiled function")) diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 230d5bfbda..82a30424d0 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -328,10 +328,18 @@ Check that the resulting binaries do not differ." (ert-deftest comp-tests-free-fun () "Check we are able to compile a single function." (defun comp-tests-free-fun-f () + "Some doc." + (interactive) 3) (load (native-compile #'comp-tests-free-fun-f)) + (should (subr-native-elisp-p (symbol-function #'comp-tests-free-fun-f))) - (should (= (comp-tests-free-fun-f) 3))) + (should (= (comp-tests-free-fun-f) 3)) + (should (string= (documentation #'comp-tests-free-fun-f) + "Some doc.")) + (should (commandp #'comp-tests-free-fun-f)) + (should (equal (interactive-form #'comp-tests-free-fun-f) + '(interactive)))) ;;;;;;;;;;;;;;;;;;;; commit b3db331e8c36ef9706ad16c12055079bcd93c022 Author: Andrea Corallo Date: Sun Dec 8 10:28:54 2019 +0100 add native interactive support test diff --git a/test/src/comp-test-funcs.el b/test/src/comp-test-funcs.el index 5e2fb0bd99..cbf287838c 100644 --- a/test/src/comp-test-funcs.el +++ b/test/src/comp-test-funcs.el @@ -261,6 +261,17 @@ "A nice docstring" t) +(defun comp-test-interactive-form0-f (dir) + (interactive "D") + dir) + +(defun comp-test-interactive-form1-f (x y) + (interactive '(1 2)) + (+ x y)) + +(defun comp-test-interactive-form2-f () + (interactive)) + ;;;;;;;;;;;;;;;;;;;; ;; Tromey's tests ;; diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 73c1fe14ca..230d5bfbda 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -313,6 +313,18 @@ Check that the resulting binaries do not differ." (should (string= (symbol-file #'comp-tests-doc-f) (concat comp-test-src "n")))) +(ert-deftest comp-test-interactive-form () + (should (equal (interactive-form #'comp-test-interactive-form0-f) + '(interactive "D"))) + (should (equal (interactive-form #'comp-test-interactive-form1-f) + '(interactive '(1 2)))) + (should (equal (interactive-form #'comp-test-interactive-form2-f) + '(interactive nil))) + (should (cl-every #'commandp '(comp-test-interactive-form0-f + comp-test-interactive-form1-f + comp-test-interactive-form2-f))) + (should-not (commandp #'comp-tests-doc-f))) + (ert-deftest comp-tests-free-fun () "Check we are able to compile a single function." (defun comp-tests-free-fun-f () commit 3345399e87fe6100ef82c399337760ab01182240 Author: Andrea Corallo Date: Sun Dec 8 10:28:23 2019 +0100 add native documentation support test diff --git a/test/src/comp-test-funcs.el b/test/src/comp-test-funcs.el index 20d15ac0e7..5e2fb0bd99 100644 --- a/test/src/comp-test-funcs.el +++ b/test/src/comp-test-funcs.el @@ -257,6 +257,10 @@ (b 3)) (% a b))) +(defun comp-tests-doc-f () + "A nice docstring" + t) + ;;;;;;;;;;;;;;;;;;;; ;; Tromey's tests ;; diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 570dcbd1ff..73c1fe14ca 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -307,6 +307,12 @@ Check that the resulting binaries do not differ." ;; See `comp-propagate-insn' `comp-function-call-remove'. (should (= (comp-tests-func-call-removal-f) 1))) +(ert-deftest comp-tests-doc () + (should (string= (documentation #'comp-tests-doc-f) + "A nice docstring")) + (should (string= (symbol-file #'comp-tests-doc-f) + (concat comp-test-src "n")))) + (ert-deftest comp-tests-free-fun () "Check we are able to compile a single function." (defun comp-tests-free-fun-f () commit a248dfe2c3341ed73de38c2feea64ec12f053aaa Author: Andrea Corallo Date: Sat Dec 7 18:19:00 2019 +0100 native compile interactive functions support diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index e46453e851..ffd4985301 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1076,9 +1076,7 @@ the annotation emission." (cl-defmethod comp-emit-for-top-level ((form byte-to-native-function)) (let* ((name (byte-to-native-function-name form)) (f (gethash name (comp-ctxt-funcs-h comp-ctxt))) - (args (comp-func-args f)) - (c-name (comp-func-c-name f)) - (doc (comp-func-doc f))) + (args (comp-func-args f))) (cl-assert (and name f)) (comp-emit (comp-call 'comp--register-subr (make-comp-mvar :constant name) @@ -1086,8 +1084,10 @@ the annotation emission." (make-comp-mvar :constant (if (comp-args-p args) (comp-args-max args) 'many)) - (make-comp-mvar :constant c-name) - (make-comp-mvar :constant doc))))) + (make-comp-mvar :constant (comp-func-c-name f)) + (make-comp-mvar :constant (comp-func-doc f)) + (make-comp-mvar :constant + (comp-func-int-spec f)))))) (cl-defmethod comp-emit-for-top-level ((form byte-to-native-top-level)) (let ((form (byte-to-native-top-level-form form))) diff --git a/src/alloc.c b/src/alloc.c index 00da90464b..5ff0d90791 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -7450,14 +7450,14 @@ N should be nonnegative. */); static union Aligned_Lisp_Subr Swatch_gc_cons_threshold = {{{ PSEUDOVECTOR_FLAG | (PVEC_SUBR << PSEUDOVECTOR_AREA_BITS) }, { .a4 = watch_gc_cons_threshold }, - 4, 4, "watch_gc_cons_threshold", 0, {0}}}; + 4, 4, "watch_gc_cons_threshold", {0}, {0}, 0}}; XSETSUBR (watcher, &Swatch_gc_cons_threshold.s); Fadd_variable_watcher (Qgc_cons_threshold, watcher); static union Aligned_Lisp_Subr Swatch_gc_cons_percentage = {{{ PSEUDOVECTOR_FLAG | (PVEC_SUBR << PSEUDOVECTOR_AREA_BITS) }, { .a4 = watch_gc_cons_percentage }, - 4, 4, "watch_gc_cons_percentage", 0, {0}}}; + 4, 4, "watch_gc_cons_percentage", {0}, {0}, 0}}; XSETSUBR (watcher, &Swatch_gc_cons_percentage.s); Fadd_variable_watcher (Qgc_cons_percentage, watcher); } diff --git a/src/comp.c b/src/comp.c index 5a00200ee8..a15bedf41a 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3304,11 +3304,11 @@ load_comp_unit (dynlib_handle_ptr handle, Lisp_Object file) DEFUN ("comp--register-subr", Fcomp__register_subr, Scomp__register_subr, - 5, 5, 0, + 6, 6, 0, doc: /* This gets called by top_level_run during load phase to register each exported subr. */) (Lisp_Object name, Lisp_Object minarg, Lisp_Object maxarg, - Lisp_Object c_name, Lisp_Object doc) + Lisp_Object c_name, Lisp_Object doc, Lisp_Object intspec) { dynlib_handle_ptr handle = xmint_pointer (XCAR (load_handle_stack)); if (!handle) @@ -3325,7 +3325,7 @@ DEFUN ("comp--register-subr", Fcomp__register_subr, x->s.min_args = XFIXNUM (minarg); x->s.max_args = FIXNUMP (maxarg) ? XFIXNUM (maxarg) : MANY; x->s.symbol_name = xstrdup (SSDATA (Fsymbol_name (name))); - x->s.intspec = NULL; + x->s.native_intspec = intspec; x->s.native_doc = doc; x->s.native_elisp = true; defsubr (x); diff --git a/src/data.c b/src/data.c index 50dce9e464..67613881d6 100644 --- a/src/data.c +++ b/src/data.c @@ -899,6 +899,10 @@ Value, if non-nil, is a list (interactive SPEC). */) if (SUBRP (fun)) { +#ifdef HAVE_NATIVE_COMP + if (XSUBR (fun)->native_elisp && XSUBR (fun)->native_intspec) + return XSUBR (fun)->native_intspec; +#endif const char *spec = XSUBR (fun)->intspec; if (spec) return list2 (Qinteractive, diff --git a/src/lisp.h b/src/lisp.h index 1c692933cd..56aa7b151e 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -2086,7 +2086,12 @@ struct Lisp_Subr } function; short min_args, max_args; const char *symbol_name; - const char *intspec; + union { + const char *intspec; +#ifdef HAVE_NATIVE_COMP + Lisp_Object native_intspec; +#endif + }; union { EMACS_INT doc; #ifdef HAVE_NATIVE_COMP @@ -3106,7 +3111,7 @@ CHECK_INTEGER (Lisp_Object x) static union Aligned_Lisp_Subr sname = \ {{{ PVEC_SUBR << PSEUDOVECTOR_AREA_BITS }, \ { .a ## maxargs = fnname }, \ - minargs, maxargs, lname, intspec, {0}}}; \ + minargs, maxargs, lname, {intspec}, {0}, 0}}; \ Lisp_Object fnname /* defsubr (Sname); commit 48f5530e7922e4c46db1c4ab82b1c3532db724c9 Author: Andrea Corallo Date: Sat Dec 7 17:38:08 2019 +0100 add int-spec to comp-func diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 30db2f1891..e46453e851 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -234,6 +234,8 @@ Is in use to help the SSA rename pass.")) :documentation "Byte compiled version.") (doc nil :type string :documentation "Doc string.") + (int-spec nil :type list + :documentation "Interactive form.") (lap () :type list :documentation "LAP assembly representation.") (args nil :type comp-args-base) @@ -451,15 +453,14 @@ Put PREFIX in front of it." collect x) for name = (byte-to-native-function-name f) for data = (byte-to-native-function-data f) - for doc = (when (>= (length data) 5) (aref data 4)) for lap = (alist-get name byte-to-native-lap) - for lambda-list = (aref data 0) for func = (make-comp-func :name name :byte-func data - :doc doc + :doc (documentation data) + :int-spec (interactive-form data) :c-name (comp-c-func-name name "F") - :args (comp-decrypt-lambda-list lambda-list) - :lap lap + :args (comp-decrypt-arg-list (aref data 0)) + :lap (alist-get name byte-to-native-lap) :frame-size (comp-byte-frame-size data)) do (comp-log (format "Function %s:\n" name) 1) (comp-log lap 1) commit d7071c64575bd3116e154f93915ff099c6e0f3a0 Author: Andrea Corallo Date: Sat Dec 7 17:37:31 2019 +0100 spill also interactive functions diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 5d2558a579..3e354951ea 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -2714,10 +2714,7 @@ not to take responsibility for the actual compilation of the code." (push (if macro (make-byte-to-native-top-level :form `(defalias ',name '(macro . ,code) nil)) - (if (commandp code) - (make-byte-to-native-top-level ;FIXME compile interactive functions. - :form `(defalias ',name ,code)) - (make-byte-to-native-function :name name :data code))) + (make-byte-to-native-function :name name :data code)) byte-to-native-top-level-forms)) ;; Output the form by hand, that's much simpler than having ;; b-c-output-file-form analyze the defalias. commit e2855d93ee41bf23a72fdcb49bd5347512989f6f Author: Andrea Corallo Date: Sat Dec 7 17:31:54 2019 +0100 renaming comp-decrypt-lambda-list -> comp-decrypt-arg-list diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 273bda8220..30db2f1891 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -391,8 +391,8 @@ Put PREFIX in front of it." (rx (not (any "0-9a-z_"))) "" human-readable))) (concat prefix crypted "_" human-readable))) -(defun comp-decrypt-lambda-list (x) - "Decript lambda list X." +(defun comp-decrypt-arg-list (x) + "Decript argument list X." (unless (fixnump x) (signal 'native-compiler-error "can't native compile a non lexical scoped function")) @@ -427,9 +427,9 @@ Put PREFIX in front of it." (let ((lap (alist-get nil byte-to-native-lap))) (cl-assert lap) (comp-log lap 2) - (let ((lambda-list (aref (comp-func-byte-func func) 0))) + (let ((arg-list (aref (comp-func-byte-func func) 0))) (setf (comp-func-args func) - (comp-decrypt-lambda-list lambda-list) + (comp-decrypt-arg-list arg-list) (comp-func-lap func) lap (comp-func-frame-size func) commit f4de790beec514808eafd1cb22fa5eacdecd4552 Author: Andrea Corallo Date: Sat Dec 7 11:28:21 2019 +0100 add native compiled function docstring support diff --git a/lisp/help-fns.el b/lisp/help-fns.el index 0e2ae6b3c3..afa5c9be94 100644 --- a/lisp/help-fns.el +++ b/lisp/help-fns.el @@ -377,7 +377,7 @@ suitable file is found, return nil." ;; This applies to config files like ~/.emacs, ;; which people sometimes compile. ((let (fn) - (and (string-match "\\`\\..*\\.elc\\'" + (and (string-match "\\`\\..*\\.el[cn]\\'" (file-name-nondirectory file-name)) (string-equal (file-name-directory file-name) (file-name-as-directory (expand-file-name "~"))) @@ -386,7 +386,7 @@ suitable file is found, return nil." ;; When the Elisp source file can be found in the install ;; directory, return the name of that file. ((let ((lib-name - (if (string-match "[.]elc\\'" file-name) + (if (string-match "[.]el[cn]\\'" file-name) (substring-no-properties file-name 0 -1) file-name))) (or (and (file-readable-p lib-name) lib-name) @@ -399,7 +399,7 @@ suitable file is found, return nil." ;; name, convert that back to a file name and see if we ;; get the original one. If so, they are equivalent. (if (equal file-name (locate-file lib-name load-path '(""))) - (if (string-match "[.]elc\\'" lib-name) + (if (string-match "[.]el[cn]\\'" lib-name) (substring-no-properties lib-name 0 -1) lib-name) file-name)) @@ -738,6 +738,8 @@ Returns a list of the form (REAL-FUNCTION DEF ALIASED REAL-DEF)." ;; aliases before functions. (aliased (format-message "an alias for `%s'" real-def)) + ((subr-native-elisp-p def) + "native compiled Lisp function") ((subrp def) (concat beg (if (eq 'unevalled (cdr (subr-arity def))) "special form" diff --git a/src/alloc.c b/src/alloc.c index 1c6b664b22..00da90464b 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -7450,14 +7450,14 @@ N should be nonnegative. */); static union Aligned_Lisp_Subr Swatch_gc_cons_threshold = {{{ PSEUDOVECTOR_FLAG | (PVEC_SUBR << PSEUDOVECTOR_AREA_BITS) }, { .a4 = watch_gc_cons_threshold }, - 4, 4, "watch_gc_cons_threshold", 0, 0}}; + 4, 4, "watch_gc_cons_threshold", 0, {0}}}; XSETSUBR (watcher, &Swatch_gc_cons_threshold.s); Fadd_variable_watcher (Qgc_cons_threshold, watcher); static union Aligned_Lisp_Subr Swatch_gc_cons_percentage = {{{ PSEUDOVECTOR_FLAG | (PVEC_SUBR << PSEUDOVECTOR_AREA_BITS) }, { .a4 = watch_gc_cons_percentage }, - 4, 4, "watch_gc_cons_percentage", 0, 0}}; + 4, 4, "watch_gc_cons_percentage", 0, {0}}}; XSETSUBR (watcher, &Swatch_gc_cons_percentage.s); Fadd_variable_watcher (Qgc_cons_percentage, watcher); } diff --git a/src/comp.c b/src/comp.c index e2629de042..5a00200ee8 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3317,17 +3317,21 @@ DEFUN ("comp--register-subr", Fcomp__register_subr, void *func = dynlib_sym (handle, SSDATA (c_name)); eassert (func); + /* FIXME add gc support, now just leaking. */ union Aligned_Lisp_Subr *x = xmalloc (sizeof (union Aligned_Lisp_Subr)); + x->s.header.size = PVEC_SUBR << PSEUDOVECTOR_AREA_BITS; x->s.function.a0 = func; x->s.min_args = XFIXNUM (minarg); x->s.max_args = FIXNUMP (maxarg) ? XFIXNUM (maxarg) : MANY; - x->s.symbol_name = SSDATA (Fsymbol_name (name)); + x->s.symbol_name = xstrdup (SSDATA (Fsymbol_name (name))); x->s.intspec = NULL; - x->s.doc = 0; /* FIXME */ + x->s.native_doc = doc; x->s.native_elisp = true; defsubr (x); + LOADHIST_ATTACH (Fcons (Qdefun, name)); + return Qnil; } diff --git a/src/doc.c b/src/doc.c index 285c0dbbbe..369997a3db 100644 --- a/src/doc.c +++ b/src/doc.c @@ -335,6 +335,11 @@ string is passed through `substitute-command-keys'. */) xsignal1 (Qvoid_function, function); if (CONSP (fun) && EQ (XCAR (fun), Qmacro)) fun = XCDR (fun); +#ifdef HAVE_NATIVE_COMP + if (!NILP (Fsubr_native_elisp_p (fun))) + doc = XSUBR (fun)->native_doc; + else +#endif if (SUBRP (fun)) doc = make_fixnum (XSUBR (fun)->doc); #ifdef HAVE_MODULES @@ -508,7 +513,12 @@ store_function_docstring (Lisp_Object obj, EMACS_INT offset) /* Lisp_Subrs have a slot for it. */ else if (SUBRP (fun)) - XSUBR (fun)->doc = offset; + { +#ifdef HAVE_NATIVE_COMP + eassert (NILP (Fsubr_native_elisp_p (fun))); +#endif + XSUBR (fun)->doc = offset; + } /* Bytecode objects sometimes have slots for it. */ else if (COMPILEDP (fun)) diff --git a/src/lisp.h b/src/lisp.h index a84c08e566..1c692933cd 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -2087,10 +2087,13 @@ struct Lisp_Subr short min_args, max_args; const char *symbol_name; const char *intspec; - EMACS_INT doc; + union { + EMACS_INT doc; #ifdef HAVE_NATIVE_COMP - bool native_elisp; + Lisp_Object native_doc; #endif + }; + bool native_elisp; } GCALIGNED_STRUCT; union Aligned_Lisp_Subr { @@ -3103,7 +3106,7 @@ CHECK_INTEGER (Lisp_Object x) static union Aligned_Lisp_Subr sname = \ {{{ PVEC_SUBR << PSEUDOVECTOR_AREA_BITS }, \ { .a ## maxargs = fnname }, \ - minargs, maxargs, lname, intspec, 0}}; \ + minargs, maxargs, lname, intspec, {0}}}; \ Lisp_Object fnname /* defsubr (Sname); commit e05253cb9bc4a35c7dedc3cbb2830e37d385a339 Author: Andrea Corallo Date: Sat Dec 7 10:24:13 2019 +0100 let intern_c_string works creating with non-pure strings diff --git a/src/lread.c b/src/lread.c index bd7182c398..f280dad97c 100644 --- a/src/lread.c +++ b/src/lread.c @@ -4198,10 +4198,14 @@ intern_c_string_1 (const char *str, ptrdiff_t len) if (!SYMBOLP (tem)) { - /* Creating a non-pure string from a string literal not implemented yet. - We could just use make_string here and live with the extra copy. */ - eassert (!NILP (Vpurify_flag)); - tem = intern_driver (make_pure_c_string (str, len), obarray, tem); + Lisp_Object string; + + if (NILP (Vpurify_flag)) + string = make_string (str, len); + else + string = make_pure_c_string (str, len); + + tem = intern_driver (string, obarray, tem); } return tem; } commit 60a81f44e49c77ef9143a665f94f89109002133d Author: Andrea Corallo Date: Wed Nov 27 20:11:40 2019 +0100 better naming variable diff --git a/src/comp.c b/src/comp.c index bb2b851e55..e2629de042 100644 --- a/src/comp.c +++ b/src/comp.c @@ -2285,7 +2285,7 @@ define_CAR_CDR (void) gcc_jit_context_new_param (comp.ctxt, NULL, comp.bool_type, - "is_cons") }; + "cert_cons") }; /* TODO: understand why after ipa-prop pass gcc is less keen on inlining and as consequence can refuse to compile these. (see dhrystone.el) Flag this and all the one involved in ipa-prop as @@ -2374,7 +2374,7 @@ define_setcar_setcdr (void) gcc_jit_context_new_param (comp.ctxt, NULL, comp.bool_type, - "is_cons") }; + "cert_cons") }; gcc_jit_function **f_ref = !i ? &comp.setcar : &comp.setcdr; *f_ref = gcc_jit_context_new_function (comp.ctxt, NULL, @@ -2443,7 +2443,7 @@ define_add1_sub1 (void) gcc_jit_context_new_param (comp.ctxt, NULL, comp.bool_type, - "is_fixnum") }; + "cert_fixnum") }; comp.func = func[i] = gcc_jit_context_new_function (comp.ctxt, NULL, GCC_JIT_FUNCTION_INTERNAL, @@ -2457,7 +2457,7 @@ define_add1_sub1 (void) comp.block = entry_block; - /* is_fixnum || + /* cert_fixnum || ((FIXNUMP (n) && XFIXNUM (n) != MOST_POSITIVE_FIXNUM ? (XFIXNUM (n) + 1) : Fadd1 (n)) */ @@ -2526,7 +2526,7 @@ define_negate (void) gcc_jit_context_new_param (comp.ctxt, NULL, comp.bool_type, - "is_fixnum") }; + "cert_fixnum") }; comp.func = comp.negate = gcc_jit_context_new_function (comp.ctxt, NULL, @@ -2541,7 +2541,7 @@ define_negate (void) comp.block = entry_block; - /* (is_fixnum || FIXNUMP (TOP)) && XFIXNUM (TOP) != MOST_NEGATIVE_FIXNUM + /* (cert_fixnum || FIXNUMP (TOP)) && XFIXNUM (TOP) != MOST_NEGATIVE_FIXNUM ? make_fixnum (- XFIXNUM (TOP)) : Fminus (1, &TOP)) */ gcc_jit_lvalue *n = gcc_jit_param_as_lvalue (param[0]); commit 4a639f3ae9594f0d16835d5151b6dda7e83e1a1f Author: Andrea Corallo Date: Wed Nov 27 00:23:56 2019 +0100 documentation nit diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index b225d4d929..273bda8220 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -270,7 +270,7 @@ structure.") :documentation "When const-vld non nil this is used for holding a value known at compile time.") (type nil - :documentation "When non nil is used for type when known at compile + :documentation "When non nil indicates the type when known at compile time.") (ref nil :type boolean :documentation "When t the m-var is involved in a call where is passed by commit ce254ffa44e33352605e49aaa7d5fc4f545c1add Author: Andrea Corallo Date: Tue Nov 26 21:48:21 2019 +0100 do not emit elc file while native compiling diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 7be43204a1..5d2558a579 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -2032,7 +2032,9 @@ The value is non-nil if there were no errors, nil if errors." ;; emacs-lisp files in the build tree are ;; recompiled). Previously this was accomplished by ;; deleting target-file before writing it. - (rename-file tempfile target-file t)) + (if byte-native-compiling + (delete-file tempfile) + (rename-file tempfile target-file t))) (or noninteractive (message "Wrote %s" target-file))) ;; This is just to give a better error message than write-region (let ((exists (file-exists-p target-file))) commit 9a87c4404fd0097e2efa14f63b97a9df8df6c07d Author: Andrea Corallo Date: Tue Nov 26 17:13:44 2019 +0100 native-compile-async accept list as input diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index b84a3e5336..b225d4d929 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1893,18 +1893,20 @@ Return the compilation unit file name." ;;;###autoload (defun native-compile-async (input &optional jobs recursively) "Compile INPUT asynchronously. -INPUT can be either a folder or a file. +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 (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"))))) + (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-loop repeat jobs do (comp-start-async-worker)) commit 7f5f60d54340aa0b36f22057fd3f2665fbcd5d67 Author: Andrea Corallo Date: Mon Nov 25 22:16:50 2019 +0100 insert compilation end message at the bottom of the buffer diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 2ac912929d..b84a3e5336 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1852,7 +1852,9 @@ Prepare every function for final compilation and drive the C back-end." (let ((msg "Compilation finished.")) (setf comp-prc-pool ()) (with-current-buffer (get-buffer-create comp-async-buffer-name) - (insert msg "\n")) + (save-excursion + (goto-char (point-max)) + (insert msg "\n"))) (message msg))))) ;;; Compiler entry points. commit a214a29e48397cf259327e1ffb44479648301e47 Author: Andrea Corallo Date: Mon Nov 25 21:27:11 2019 +0100 fix comp-propagate-insn type propagation diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 4167dcf4b9..2ac912929d 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1553,14 +1553,19 @@ This can run just once." (comp-mvar-propagate lval rval)))) (`(phi ,lval . ,rest) ;; Const prop here. - (when (and (cl-every #'comp-mvar-const-vld rest) - (cl-reduce #'equal (mapcar #'comp-mvar-constant rest))) - (setf (comp-mvar-constant lval) (comp-mvar-constant (car rest)))) + (when-let* ((vld (cl-every #'comp-mvar-const-vld rest)) + (consts (mapcar #'comp-mvar-constant rest)) + (x (car consts)) + (equals (cl-every (lambda (y) (equal x y)) consts))) + (setf (comp-mvar-constant lval) x)) ;; Type propagation. ;; FIXME: checking for type equality is not sufficient cause does not - ;; account type hierarchy!! - (when (cl-reduce #'eq (mapcar #'comp-mvar-type rest)) - (setf (comp-mvar-type lval) (comp-mvar-type (car rest)))) + ;; account type hierarchy! + (when-let* ((types (mapcar #'comp-mvar-type rest)) + (non-empty (cl-notany #'null types)) + (x (car types)) + (eqs (cl-every (lambda (y) (eq x y)) types))) + (setf (comp-mvar-type lval) x)) ;; Reference propagation. (let ((operands (cons lval rest))) (when (cl-some #'comp-mvar-ref operands) commit 5411beae0225937446eb8509c56277b120a2eb92 Author: Andrea Corallo Date: Mon Nov 25 20:33:47 2019 +0100 remove unnecessary return when printing blocks diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 5f0b61b734..4167dcf4b9 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -352,7 +352,7 @@ VERBOSITY is a number between 0 and 3." (comp-log (format "\nFunction: %s\n" (comp-func-name func)) verbosity) (cl-loop for block-name being each hash-keys of (comp-func-blocks func) using (hash-value bb) - do (comp-log (concat "<" (symbol-name block-name) ">\n") verbosity) + do (comp-log (concat "<" (symbol-name block-name) ">") verbosity) (comp-log (comp-block-insns bb) verbosity)))) (defun comp-log-edges (func) commit ba51c31b47a62e6815d8cb2cb34ecd642a677105 Author: Andrea Corallo Date: Mon Nov 25 20:33:17 2019 +0100 gate propagate to comp-speed > 1 diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index f9c0d62147..5f0b61b734 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1580,15 +1580,16 @@ Return t if something was changed." finally return modified)) (defun comp-propagate (_) - (maphash (lambda (_ f) - (let ((comp-func f)) - (comp-basic-const-propagate) - (cl-loop - for i from 1 - while (comp-propagate*) - finally (comp-log (format "Propagation run %d times\n" i) 2)) - (comp-log-func comp-func 3))) - (comp-ctxt-funcs-h comp-ctxt))) + (when (>= comp-speed 2) + (maphash (lambda (_ f) + (let ((comp-func f)) + (comp-basic-const-propagate) + (cl-loop + for i from 1 + while (comp-propagate*) + finally (comp-log (format "Propagation run %d times\n" i) 2)) + (comp-log-func comp-func 3))) + (comp-ctxt-funcs-h comp-ctxt)))) ;;; Call optimizer pass specific code. commit 10adad440b2eb3b09d9d4e876023dd13d8b3dab9 Author: Andrea Corallo Date: Sun Nov 24 23:23:16 2019 +0100 update limple example diff --git a/src/comp.c b/src/comp.c index be92893d65..bb2b851e55 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1456,7 +1456,7 @@ emit_limple_insn (Lisp_Object insn) } else if (EQ (op, Qsetimm)) { - /* Ex: (=imm #s(comp-mvar 9 1 t 3 nil) 3 a). */ + /* Ex: (setimm #s(comp-mvar 9 1 t 3 nil) 3 a). */ gcc_jit_rvalue *reloc_n = gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.int_type, commit 6a3624eecbc0a116b293d05e044b8b40a86022e9 Author: Andrea Corallo Date: Sun Nov 24 23:22:49 2019 +0100 fix wrong enum usage into declare_function diff --git a/src/comp.c b/src/comp.c index fd7707a263..be92893d65 100644 --- a/src/comp.c +++ b/src/comp.c @@ -2757,7 +2757,7 @@ declare_function (Lisp_Object func) type[i], format_string ("par_%d", i)); gcc_func = gcc_jit_context_new_function (comp.ctxt, NULL, - GCC_JIT_GLOBAL_EXPORTED, + GCC_JIT_FUNCTION_EXPORTED, comp.lisp_obj_type, c_name, max_args, commit 44023f3db21c0365ceeb179657447d7cdb1feb8f Author: Andrea Corallo Date: Sun Nov 24 19:50:15 2019 +0100 fix comp-log-edges diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 60cfd8e516..f9c0d62147 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -358,17 +358,15 @@ VERBOSITY is a number between 0 and 3." (defun comp-log-edges (func) "Log edges in FUNC." (let ((edges (comp-func-edges func))) - (when (> comp-verbose 2) - (comp-log (format "\nEdges in function: %s\n" - (comp-func-name func)) - 0)) + (comp-log (format "\nEdges in function: %s\n" + (comp-func-name func)) + 2) (mapc (lambda (e) - (when (> comp-verbose 2) - (comp-log (format "n: %d src: %s dst: %s\n" - (comp-edge-number e) - (comp-block-name (comp-edge-src e)) - (comp-block-name (comp-edge-dst e))) - 0))) + (comp-log (format "n: %d src: %s dst: %s\n" + (comp-edge-number e) + (comp-block-name (comp-edge-src e)) + (comp-block-name (comp-edge-dst e))) + 2)) edges))) commit ba2bbea816ac5a20fa3090b634a17ed0d4a1c2ca Author: Andrea Corallo Date: Sun Nov 24 19:49:25 2019 +0100 adjust print verbosity according to the doc diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 1f23edb58f..60cfd8e516 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -428,7 +428,7 @@ Put PREFIX in front of it." (byte-compile (comp-func-name func))) (let ((lap (alist-get nil byte-to-native-lap))) (cl-assert lap) - (comp-log lap 1) + (comp-log lap 2) (let ((lambda-list (aref (comp-func-byte-func func) 0))) (setf (comp-func-args func) (comp-decrypt-lambda-list lambda-list) @@ -1776,6 +1776,9 @@ Prepare every function for final compilation and drive the C back-end." (defun comp-final (_) "Final pass driving the C back-end for code emission." (let (compile-result) + (maphash (lambda (_ f) + (comp-log-func f 1)) + (comp-ctxt-funcs-h comp-ctxt)) (comp--init-ctxt) (unwind-protect (setf compile-result commit 9650e5a1a90768953ce9f3eef014616180bfed8e Author: Andrea Corallo Date: Sun Nov 24 18:48:37 2019 +0100 revert unnecessary modifications diff --git a/lisp/emacs-lisp/byte-run.el b/lisp/emacs-lisp/byte-run.el index fedbd61ffd..6a49c60099 100644 --- a/lisp/emacs-lisp/byte-run.el +++ b/lisp/emacs-lisp/byte-run.el @@ -597,6 +597,4 @@ Otherwise, return nil. For internal use only." (make-obsolete 'macro-declaration-function 'macro-declarations-alist "24.3") -(provide 'byte-run) - ;;; byte-run.el ends here diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index ebbee2a0c7..7be43204a1 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -124,7 +124,6 @@ (require 'backquote) (require 'macroexp) (require 'cconv) -(require 'byte-run) (eval-when-compile (require 'compile)) ;; Refrain from using cl-lib at run-time here, since it otherwise prevents ;; us from emitting warnings when compiling files which use cl-lib without diff --git a/src/lread.c b/src/lread.c index f1b17edd01..bd7182c398 100644 --- a/src/lread.c +++ b/src/lread.c @@ -4195,16 +4195,13 @@ intern_c_string_1 (const char *str, ptrdiff_t len) { Lisp_Object obarray = check_obarray (Vobarray); Lisp_Object tem = oblookup (obarray, str, len, len); - Lisp_Object string; if (!SYMBOLP (tem)) { - if (NILP (Vpurify_flag)) - string = make_string (str, len); - else - string = make_pure_c_string (str, len); - - tem = intern_driver (string, obarray, tem); + /* Creating a non-pure string from a string literal not implemented yet. + We could just use make_string here and live with the extra copy. */ + eassert (!NILP (Vpurify_flag)); + tem = intern_driver (make_pure_c_string (str, len), obarray, tem); } return tem; } commit 831f5e606125c48f783daee9643d101b7fad665f Author: Andrea Corallo Date: Sun Nov 24 18:42:40 2019 +0100 make buffer names constant diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index b1460f21c5..1f23edb58f 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -75,14 +75,10 @@ This intended for debugging the compiler itself. :group 'comp) (defconst comp-log-buffer-name "*Native-compile-Log*" - "Name of the native-compiler log buffer." - :type 'string - :group 'comp) + "Name of the native-compiler log buffer.") -(defcustom comp-async-buffer-name "*Async-compilation*" - "Name of the async compilation buffer log." - :type 'string - :group 'comp) +(defconst comp-async-buffer-name "*Async-native-compile-log*" + "Name of the async compilation buffer log.") (defvar comp-native-compiling nil "This gets bound to t while native compilation. commit f0b1519fbd0fea728238758d6bec074c32be1142 Author: Andrea Corallo Date: Sun Nov 24 18:34:54 2019 +0100 rename native-compile-log-buffer -> comp-log-buffer-name diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 28b83a6199..b1460f21c5 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -74,8 +74,10 @@ This intended for debugging the compiler itself. :type 'boolean :group 'comp) -(defconst native-compile-log-buffer "*Native-compile-Log*" - "Name of the native-compiler log buffer.") +(defconst comp-log-buffer-name "*Native-compile-Log*" + "Name of the native-compiler log buffer." + :type 'string + :group 'comp) (defcustom comp-async-buffer-name "*Async-compilation*" "Name of the async compilation buffer log." @@ -324,7 +326,7 @@ 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 native-compile-log-buffer) + (with-current-buffer (get-buffer-create comp-log-buffer-name) (setf buffer-read-only t) (let ((inhibit-read-only t)) (goto-char (point-max)) commit ea421cfefef6826dd99a9cc884b46178b2c0e1a8 Author: Andrea Corallo Date: Sun Nov 24 18:25:04 2019 +0100 do not use thread for async compilation diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 1815b1709a..28b83a6199 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -77,6 +77,11 @@ This intended for debugging the compiler itself. (defconst native-compile-log-buffer "*Native-compile-Log*" "Name of the native-compiler log buffer.") +(defcustom comp-async-buffer-name "*Async-compilation*" + "Name of the async compilation buffer log." + :type 'string + :group 'comp) + (defvar comp-native-compiling nil "This gets bound to t while native compilation. Can be used by code that wants to expand differently in this case.") @@ -1803,8 +1808,8 @@ Prepare every function for final compilation and drive the C back-end." (defvar comp-src-pool () "List containing the files to be compiled.") -(defvar comp-src-pool-mutex (make-mutex) - "Mutex for `comp-src-pool'.") +(defvar comp-prc-pool () + "List containing all async compilation processes.") (defun comp-to-file-p (file) "Return t if FILE has to be compiled." @@ -1813,32 +1818,37 @@ Prepare every function for final compilation and drive the C back-end." (not (and (file-exists-p compiled-f) (file-newer-than-file-p compiled-f file)))))) -(defun comp-start-async-worker () - "Start an async compiler worker." - (make-thread - (lambda () - (let (f) - (while (setf f (with-mutex comp-src-pool-mutex - (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))) - (prc (start-process (concat "Compiling: " f) - "async-compile-buffer" - (concat invocation-directory invocation-name) - "--batch" - "--eval" - (prin1-to-string code)))) - (while (accept-process-output prc) - (thread-yield))))) - (message "Finished compiling."))) - "compilation thread")) +(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) + (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) + (let ((msg "Compilation finished.")) + (setf comp-prc-pool ()) + (with-current-buffer (get-buffer-create comp-async-buffer-name) + (insert msg "\n")) + (message msg))))) ;;; Compiler entry points. @@ -1888,10 +1898,10 @@ Follow folders RECURSIVELY if non nil." (list input) (signal 'native-compiler-error "input not a file nor directory"))))) - (with-mutex comp-src-pool-mutex - (setf comp-src-pool (nconc files comp-src-pool))) + (setf comp-src-pool (nconc files comp-src-pool)) (cl-loop repeat jobs - do (comp-start-async-worker)))) + do (comp-start-async-worker)) + (message "Compilation started."))) (provide 'comp) commit d4a5aba954c838b32317560dd84e6681578b0e32 Author: Andrea Corallo Date: Sun Nov 24 16:39:56 2019 +0100 update limple comments diff --git a/src/comp.c b/src/comp.c index cbc91758fa..fd7707a263 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1083,9 +1083,8 @@ static gcc_jit_rvalue * emit_set_internal (Lisp_Object args) { /* - Ex: (call set_internal - #s(comp-mvar 7 nil t xxx nil) - #s(comp-mvar 6 1 t 3 nil)) + Ex: (set_internal #s(comp-mvar nil nil t comp-test-up-val nil nil) + #s(comp-mvar 1 4 t nil symbol nil)). */ /* TODO: Inline the most common case. */ if (list_length (args) != 3) @@ -1128,8 +1127,7 @@ static gcc_jit_rvalue * emit_simple_limple_call_lisp_ret (Lisp_Object args) { /* - Ex: (call Fcons #s(comp-mvar 3 0 t 1 nil) - #s(comp-mvar 4 nil t nil nil)) + Ex: (call Fcons #s(comp-mvar 3 0 t 1 nil) #s(comp-mvar 4 nil t nil nil)). */ return emit_simple_limple_call (args, comp.lisp_obj_type, false); } @@ -1160,8 +1158,9 @@ emit_limple_call (Lisp_Object insn) static gcc_jit_rvalue * emit_limple_call_ref (Lisp_Object insn, bool direct) { - /* Ex: (callref < #s(comp-mvar 1 6 nil nil nil t) - #s(comp-mvar 2 11 t 10 integer t)). */ + /* Ex: (funcall #s(comp-mvar 1 5 t eql symbol t) + #s(comp-mvar 2 6 nil nil nil t) + #s(comp-mvar 3 7 t 0 fixnum t)). */ Lisp_Object callee = FIRST (insn); EMACS_INT nargs = XFIXNUM (Flength (CDR (insn))); @@ -1384,7 +1383,7 @@ emit_limple_insn (Lisp_Object insn) } else if (EQ (op, Qset_par_to_local)) { - /* Ex: (setpar #s(comp-mvar 2 0 nil nil nil) 0). */ + /* Ex: (set-par-to-local #s(comp-mvar 0 3 nil nil nil nil) 0). */ EMACS_INT param_n = XFIXNUM (arg[1]); gcc_jit_rvalue *param = gcc_jit_param_as_rvalue (gcc_jit_function_get_param (comp.func, @@ -1394,7 +1393,7 @@ emit_limple_insn (Lisp_Object insn) else if (EQ (op, Qset_args_to_local)) { /* - Limple: (set-args-to-local #s(comp-mvar 1 6 nil nil nil nil)) + Ex: (set-args-to-local #s(comp-mvar 1 6 nil nil nil nil)) C: local[1] = *args; */ gcc_jit_rvalue *gcc_args = @@ -1409,7 +1408,7 @@ emit_limple_insn (Lisp_Object insn) else if (EQ (op, Qset_rest_args_to_local)) { /* - Limple: (set-rest-args-to-local #s(comp-mvar 2 9 nil nil nil nil)) + Ex: (set-rest-args-to-local #s(comp-mvar 2 9 nil nil nil nil)) C: local[2] = list (nargs - 2, args); */ @@ -1440,7 +1439,7 @@ emit_limple_insn (Lisp_Object insn) else if (EQ (op, Qinc_args)) { /* - Limple: (inc-args) + Ex: (inc-args) C: ++args; */ gcc_jit_lvalue *args = @@ -1457,7 +1456,7 @@ emit_limple_insn (Lisp_Object insn) } else if (EQ (op, Qsetimm)) { - /* EX: (=imm #s(comp-mvar 9 1 t 3 nil) 3 a). */ + /* Ex: (=imm #s(comp-mvar 9 1 t 3 nil) 3 a). */ gcc_jit_rvalue *reloc_n = gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.int_type, @@ -1473,7 +1472,7 @@ emit_limple_insn (Lisp_Object insn) } else if (EQ (op, Qcomment)) { - /* Ex: (comment "Function: foo"). */ + /* Ex: (comment "Function: foo"). */ emit_comment (SSDATA (arg[0])); } else if (EQ (op, Qreturn)) commit d2d229043674c59dead9a58a9ae20f8e62427fc1 Author: Andrea Corallo Date: Sun Nov 24 16:21:43 2019 +0100 better comp-byte-frame-size diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 47d4de87c6..1815b1709a 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -406,11 +406,9 @@ Put PREFIX in front of it." :nonrest nonrest :rest rest)))) -(defun comp-byte-frame-size (byte-compiled-func) +(defsubst comp-byte-frame-size (byte-compiled-func) "Given BYTE-COMPILED-FUNC return the frame size to be allocated." - ;; Is this really correct? - ;; For the 1+ see bytecode.c:365 (finger crossed). - (1+ (aref byte-compiled-func 3))) + (aref byte-compiled-func 3)) (cl-defgeneric comp-spill-lap-function (input) "Byte compile INPUT and spill lap for further stages.") @@ -431,7 +429,8 @@ Put PREFIX in front of it." (let ((lambda-list (aref (comp-func-byte-func func) 0))) (setf (comp-func-args func) (comp-decrypt-lambda-list lambda-list) - (comp-func-lap func) lap + (comp-func-lap func) + lap (comp-func-frame-size func) (comp-byte-frame-size (comp-func-byte-func func)))) (setf (comp-ctxt-top-level-forms comp-ctxt) commit 4fc8524df0e2ce0579d6bc298dc07d1e442587c6 Author: Andrea Corallo Date: Sun Nov 24 16:18:51 2019 +0100 fix single function top level generation diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 217b7ffcd8..47d4de87c6 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -434,6 +434,8 @@ Put PREFIX in front of it." (comp-func-lap func) lap (comp-func-frame-size func) (comp-byte-frame-size (comp-func-byte-func func)))) + (setf (comp-ctxt-top-level-forms comp-ctxt) + (list (make-byte-to-native-function :name function-name))) (list func)))) (cl-defgeneric comp-spill-lap-function ((filename string)) commit 0c94e69fa6ed5a4f5d551f37f7f2632d2f2b2952 Author: Andrea Corallo Date: Sun Nov 24 16:03:01 2019 +0100 add comp-tests-free-fun diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 361f116eda..570dcbd1ff 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -30,7 +30,7 @@ (require 'comp) ;; (setq comp-debug 1) -(setq comp-speed 3) +(setq comp-speed 0) (defconst comp-test-directory (file-name-directory (or load-file-name buffer-file-name))) @@ -307,6 +307,14 @@ Check that the resulting binaries do not differ." ;; See `comp-propagate-insn' `comp-function-call-remove'. (should (= (comp-tests-func-call-removal-f) 1))) +(ert-deftest comp-tests-free-fun () + "Check we are able to compile a single function." + (defun comp-tests-free-fun-f () + 3) + (load (native-compile #'comp-tests-free-fun-f)) + (should (subr-native-elisp-p (symbol-function #'comp-tests-free-fun-f))) + (should (= (comp-tests-free-fun-f) 3))) + ;;;;;;;;;;;;;;;;;;;; ;; Tromey's tests ;; commit 960aa0c7985f6c61a26f99653c6e9ae9369e944e Author: Andrea Corallo Date: Sun Nov 24 15:07:54 2019 +0100 review two slot names in comp-func diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 7358e8616c..217b7ffcd8 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -223,10 +223,10 @@ Is in use to help the SSA rename pass.")) (cl-defstruct (comp-func (:copier nil)) "LIMPLE representation of a function." - (symbol-name nil - :documentation "Function's symbol name.") - (c-func-name nil :type string - :documentation "The function name in the native world.") + (name nil :type symbol + :documentation "Function symbol name.") + (c-name nil :type string + :documentation "The function name in the native world.") (byte-func nil :documentation "Byte compiled version.") (doc nil :type string @@ -346,7 +346,7 @@ BODY is evaluate only if `comp-verbose' is > 0." "Log function FUNC. VERBOSITY is a number between 0 and 3." (when (>= comp-verbose verbosity) - (comp-log (format "\nFunction: %s\n" (comp-func-symbol-name func)) verbosity) + (comp-log (format "\nFunction: %s\n" (comp-func-name func)) verbosity) (cl-loop for block-name being each hash-keys of (comp-func-blocks func) using (hash-value bb) do (comp-log (concat "<" (symbol-name block-name) ">\n") verbosity) @@ -357,7 +357,7 @@ VERBOSITY is a number between 0 and 3." (let ((edges (comp-func-edges func))) (when (> comp-verbose 2) (comp-log (format "\nEdges in function: %s\n" - (comp-func-symbol-name func)) + (comp-func-name func)) 0)) (mapc (lambda (e) (when (> comp-verbose 2) @@ -418,15 +418,13 @@ Put PREFIX in front of it." (cl-defgeneric comp-spill-lap-function ((function-name symbol)) "Byte compile FUNCTION-NAME spilling data from the byte compiler." (let* ((f (symbol-function function-name)) - (func (make-comp-func :symbol-name function-name - :c-func-name (comp-c-func-name - function-name - "F")))) + (func (make-comp-func :name function-name + :c-name (comp-c-func-name function-name"F")))) (when (byte-code-function-p f) (signal 'native-compiler-error "can't native compile an already bytecompiled function")) (setf (comp-func-byte-func func) - (byte-compile (comp-func-symbol-name func))) + (byte-compile (comp-func-name func))) (let ((lap (alist-get nil byte-to-native-lap))) (cl-assert lap) (comp-log lap 1) @@ -454,12 +452,10 @@ Put PREFIX in front of it." for doc = (when (>= (length data) 5) (aref data 4)) for lap = (alist-get name byte-to-native-lap) for lambda-list = (aref data 0) - for func = (make-comp-func :symbol-name name + for func = (make-comp-func :name name :byte-func data :doc doc - :c-func-name (comp-c-func-name - name - "F") + :c-name (comp-c-func-name name "F") :args (comp-decrypt-lambda-list lambda-list) :lap lap :frame-size (comp-byte-frame-size data)) @@ -1078,7 +1074,7 @@ the annotation emission." (let* ((name (byte-to-native-function-name form)) (f (gethash name (comp-ctxt-funcs-h comp-ctxt))) (args (comp-func-args f)) - (c-name (comp-func-c-func-name f)) + (c-name (comp-func-c-name f)) (doc (comp-func-doc f))) (cl-assert (and name f)) (comp-emit (comp-call 'comp--register-subr @@ -1099,10 +1095,10 @@ the annotation emission." (defun comp-limplify-top-level () "Create a limple function doing the business for top level forms. This will be called at load-time." - (let* ((func (make-comp-func :symbol-name 'top-level-run - :c-func-name "top_level_run" - :args (make-comp-args :min 0 :max 0) - :frame-size 0)) + (let* ((func (make-comp-func :name 'top-level-run + :c-name "top_level_run" + :args (make-comp-args :min 0 :max 0) + :frame-size 0)) (comp-func func) (comp-pass (make-comp-limplify :curr-block (make--comp-block -1 0 'top-level) @@ -1163,7 +1159,7 @@ This will be called at load-time." ;; Prologue (comp-make-curr-block 'entry (comp-sp)) (comp-emit-annotation (concat "Lisp function: " - (symbol-name (comp-func-symbol-name func)))) + (symbol-name (comp-func-name func)))) (if (comp-args-p args) (cl-loop for i below (comp-args-max args) do (cl-incf (comp-sp)) @@ -1188,7 +1184,7 @@ This will be called at load-time." (defun comp-add-func-to-ctxt (func) "Add FUNC to the current compiler contex." - (puthash (comp-func-symbol-name func) + (puthash (comp-func-name func) func (comp-ctxt-funcs-h comp-ctxt))) @@ -1243,7 +1239,7 @@ Top level forms for the current context are rendered too." (signal 'native-ice (list "block does not end with a branch" bb - (comp-func-symbol-name comp-func))))) + (comp-func-name comp-func))))) finally (setf (comp-func-edges comp-func) (nreverse (comp-func-edges comp-func))) ;; Update edge refs into blocks. @@ -1657,7 +1653,7 @@ Return t if something was changed." (defun comp-call-optim-func () "Perform the trampoline call optimization for the current function." (cl-loop - with self = (comp-func-symbol-name comp-func) + with self = (comp-func-name comp-func) for b being each hash-value of (comp-func-blocks comp-func) do (cl-loop for insn-cell on (comp-block-insns b) @@ -1717,7 +1713,7 @@ Return the list of m-var ids nuked." ;; exist and gets nuked. (let ((nuke-list (cl-set-difference l-vals r-vals))) (comp-log (format "Function %s\nl-vals %s\nr-vals %s\nNuking ids: %s\n" - (comp-func-symbol-name comp-func) + (comp-func-name comp-func) l-vals r-vals nuke-list) diff --git a/src/comp.c b/src/comp.c index e7b8a04425..cbc91758fa 100644 --- a/src/comp.c +++ b/src/comp.c @@ -2739,7 +2739,7 @@ static void declare_function (Lisp_Object func) { gcc_jit_function *gcc_func; - char *c_name = SSDATA (CALL1I (comp-func-c-func-name, func)); + char *c_name = SSDATA (CALL1I (comp-func-c-name, func)); Lisp_Object args = CALL1I (comp-func-args, func); bool nargs = (CALL1I (comp-nargs-p, args)); USE_SAFE_ALLOCA; @@ -2784,7 +2784,7 @@ declare_function (Lisp_Object func) c_name, 2, param, 0); } - Fputhash (CALL1I (comp-func-symbol-name, func), + Fputhash (CALL1I (comp-func-name, func), make_mint_ptr (gcc_func), comp.exported_funcs_h); @@ -2797,7 +2797,7 @@ compile_function (Lisp_Object func) USE_SAFE_ALLOCA; EMACS_INT frame_size = XFIXNUM (CALL1I (comp-func-frame-size, func)); - comp.func = xmint_pointer (Fgethash (CALL1I (comp-func-symbol-name, func), + comp.func = xmint_pointer (Fgethash (CALL1I (comp-func-name, func), comp.exported_funcs_h, Qnil)); gcc_jit_lvalue *frame_array = @@ -2883,7 +2883,7 @@ compile_function (Lisp_Object func) if (err) xsignal3 (Qnative_ice, build_string ("failing to compile function"), - CALL1I (comp-func-symbol-name, func), + CALL1I (comp-func-name, func), build_string (err)); SAFE_FREE (); commit c039822082983d6618b6e06c73a31cf6b63467cc Author: Andrea Corallo Date: Sat Nov 23 17:27:44 2019 +0100 better style into comp-tests-bootstrap diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index a0e6e23cef..361f116eda 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -45,16 +45,12 @@ Check that the resulting binaries do not differ." (let* ((comp-src (concat comp-test-directory "../../lisp/emacs-lisp/comp.el")) - (comp1-src (concat temporary-file-directory - (make-temp-name "stage1-") - ".el")) - (comp2-src (concat temporary-file-directory - (make-temp-name "stage2-") - ".el")) + (comp1-src (make-temp-file "stage1-" nil ".el")) + (comp2-src (make-temp-file "stage2-" nil ".el")) (comp1 (concat comp1-src "n")) (comp2 (concat comp2-src "n"))) - (copy-file comp-src comp1-src) - (copy-file comp-src comp2-src) + (copy-file comp-src comp1-src t) + (copy-file comp-src comp2-src t) (load (concat comp-src "c") nil nil t t) (should (null (subr-native-elisp-p (symbol-function #'native-compile)))) (message "Compiling stage1...") commit a421c277237ab6b5923473f6dbb9c196b16bc833 Author: Andrea Corallo Date: Sat Nov 23 17:03:08 2019 +0100 fix single function compilation diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 04c80c1757..ebbee2a0c7 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -3147,9 +3147,8 @@ for symbols generated by the byte compiler itself." byte-compile-vector byte-compile-maxdepth))) (when byte-native-compiling ;; Spill LAP for the native compiler here - (when byte-compile-current-form - (push (cons byte-compile-current-form byte-compile-output) - byte-to-native-lap))) + (push (cons byte-compile-current-form byte-compile-output) + byte-to-native-lap)) out)) ;; it's a trivial function ((cdr body) (cons 'progn (nreverse body))) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 458c95a322..7358e8616c 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -102,7 +102,7 @@ Can be used by code that wants to expand differently in this case.") (* . number) (/ . number) (% . number) - ;; Type hint + ;; Type hints (comp-hint-fixnum . fixnum) (comp-hint-cons . cons)) "Alist used for type propagation.") @@ -412,31 +412,33 @@ Put PREFIX in front of it." ;; For the 1+ see bytecode.c:365 (finger crossed). (1+ (aref byte-compiled-func 3))) -(defun comp-spill-lap-function (_function-name) +(cl-defgeneric comp-spill-lap-function (input) + "Byte compile INPUT and spill lap for further stages.") + +(cl-defgeneric comp-spill-lap-function ((function-name symbol)) "Byte compile FUNCTION-NAME spilling data from the byte compiler." - (signal 'native-ice "to be reimplemented") - ;; (let* ((f (symbol-function function-name)) - ;; (func (make-comp-func :symbol-name function-name - ;; :c-func-name (comp-c-func-name - ;; function-name - ;; "F")))) - ;; (when (byte-code-function-p f) - ;; (error "Can't native compile an already bytecompiled function")) - ;; (setf (comp-func-byte-func func) - ;; (byte-compile (comp-func-symbol-name func))) - ;; (let ((lap (alist-get function-name (reverse byte-to-native-bytecode)))) - ;; (cl-assert lap) - ;; (comp-log lap) - ;; (let ((lambda-list (aref (comp-func-byte-func func) 0))) - ;; (setf (comp-func-args func) - ;; (comp-decrypt-lambda-list lambda-list))) - ;; (setf (comp-func-lap func) lap) - ;; (setf (comp-func-frame-size func) - ;; (comp-byte-frame-size (comp-func-byte-func func))) - ;; func)) - ) - -(defun comp-spill-lap-functions-file (filename) + (let* ((f (symbol-function function-name)) + (func (make-comp-func :symbol-name function-name + :c-func-name (comp-c-func-name + function-name + "F")))) + (when (byte-code-function-p f) + (signal 'native-compiler-error + "can't native compile an already bytecompiled function")) + (setf (comp-func-byte-func func) + (byte-compile (comp-func-symbol-name func))) + (let ((lap (alist-get nil byte-to-native-lap))) + (cl-assert lap) + (comp-log lap 1) + (let ((lambda-list (aref (comp-func-byte-func func) 0))) + (setf (comp-func-args func) + (comp-decrypt-lambda-list lambda-list) + (comp-func-lap func) lap + (comp-func-frame-size func) + (comp-byte-frame-size (comp-func-byte-func func)))) + (list func)))) + +(cl-defgeneric comp-spill-lap-function ((filename string)) "Byte compile FILENAME spilling data from the byte compiler." (byte-compile-file filename) (unless byte-to-native-top-level-forms @@ -472,9 +474,7 @@ If INPUT is a string this is the file path to be compiled." (let ((byte-native-compiling t) (byte-to-native-lap ()) (byte-to-native-top-level-forms ())) - (cl-typecase input - (symbol (list (comp-spill-lap-function input))) - (string (comp-spill-lap-functions-file input))))) + (comp-spill-lap-function input))) ;;; Limplification pass specific code. @@ -1860,7 +1860,7 @@ Return the compilation unit file name." (comp-native-compiling t) (comp-ctxt (make-comp-ctxt :output (if (symbolp input) - (symbol-name input) + (make-temp-file (concat (symbol-name input) "-")) (file-name-sans-extension (expand-file-name input)))))) (comp-log "\n \n" 1) (condition-case err commit d901221e2bb2168cd1f05e3b2355e078c45f1f42 Author: Andrea Corallo Date: Sat Nov 23 09:56:56 2019 +0100 style fixes into comp.c diff --git a/src/comp.c b/src/comp.c index 61f297ea3d..e7b8a04425 100644 --- a/src/comp.c +++ b/src/comp.c @@ -34,7 +34,7 @@ along with GNU Emacs. If not, see . */ #include "buffer.h" #include "blockinput.h" -/* C symbols emited for the load relocation mechanism. */ +/* C symbols emitted for the load relocation mechanism. */ #define CURRENT_THREAD_RELOC_SYM "current_thread_reloc" #define PURE_RELOC_SYM "pure_reloc" #define DATA_RELOC_SYM "d_reloc" @@ -115,7 +115,7 @@ typedef struct { gcc_jit_field *m_handlerlist; gcc_jit_type *thread_state_ptr_type; gcc_jit_rvalue *current_thread_ref; - /* other globals */ + /* Other globals. */ gcc_jit_rvalue *pure_ref; /* libgccjit has really limited support for casting therefore this union will be used for the scope. */ @@ -175,7 +175,7 @@ typedef struct { /* - Helper functions called by the runtime. + Helper functions called by the run-time. */ Lisp_Object helper_save_window_excursion (Lisp_Object v1); void helper_unwind_protect (Lisp_Object handler); @@ -208,6 +208,7 @@ bcall0 (Lisp_Object f) Ffuncall (1, &f); } +/* Try to return the original subr from `symbol' even if this was advised. */ static Lisp_Object symbol_subr (Lisp_Object symbol) { @@ -323,7 +324,7 @@ emit_comment (const char *str) /* Declare an imported function. When nargs is MANY (ptrdiff_t nargs, Lisp_Object *args) signature is assumed. - When types is NULL types is assumed to be all Lisp_Objects. + When types is NULL args are assumed to be all Lisp_Objects. */ static gcc_jit_field * declare_imported_func (Lisp_Object subr_sym, gcc_jit_type *ret_type, @@ -342,7 +343,7 @@ declare_imported_func (Lisp_Object subr_sym, gcc_jit_type *ret_type, types[0] = comp.ptrdiff_type; types[1] = comp.lisp_obj_ptr_type; } - if (nargs == UNEVALLED) + else if (nargs == UNEVALLED) { nargs = 1; types = alloca (nargs * sizeof (* types)); @@ -681,11 +682,11 @@ emit_BIGNUMP (gcc_jit_rvalue *obj) /* PSEUDOVECTORP (x, PVEC_BIGNUM); */ emit_comment ("BIGNUMP"); - gcc_jit_rvalue *args[2] = { - obj, - gcc_jit_context_new_rvalue_from_int (comp.ctxt, - comp.int_type, - PVEC_BIGNUM) }; + gcc_jit_rvalue *args[] = + { obj, + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.int_type, + PVEC_BIGNUM) }; return gcc_jit_context_new_call (comp.ctxt, NULL, @@ -1598,7 +1599,7 @@ emit_integerp (Lisp_Object insn) } /* This is in charge of serializing an object and export a function to - retrive it at load time. */ + retrieve it at load time. */ static void emit_static_object (const char *name, Lisp_Object obj) { @@ -1760,7 +1761,7 @@ declare_runtime_imported_funcs (void) } /* -This emit the code needed by every compilation unit to be loaded. + This emit the code needed by every compilation unit to be loaded. */ static void emit_ctxt_code (void) @@ -2386,10 +2387,10 @@ define_setcar_setcdr (void) comp.func = *f_ref; comp.block = entry_block; - /* CHECK_CONS (cell); */ + /* CHECK_CONS (cell); */ emit_CHECK_CONS (gcc_jit_param_as_rvalue (cell)); - /* CHECK_IMPURE (cell, XCONS (cell)); */ + /* CHECK_IMPURE (cell, XCONS (cell)); */ gcc_jit_rvalue *args[] = { gcc_jit_param_as_rvalue (cell), emit_XCONS (gcc_jit_param_as_rvalue (cell)) }; @@ -2402,7 +2403,7 @@ define_setcar_setcdr (void) 2, args)); - /* XSETCDR (cell, newel); */ + /* XSETCDR (cell, newel); */ if (!i) emit_XSETCAR (gcc_jit_param_as_rvalue (cell), gcc_jit_param_as_rvalue (new_el)); @@ -2410,7 +2411,7 @@ define_setcar_setcdr (void) emit_XSETCDR (gcc_jit_param_as_rvalue (cell), gcc_jit_param_as_rvalue (new_el)); - /* return newel; */ + /* return newel; */ gcc_jit_block_end_with_return (entry_block, NULL, gcc_jit_param_as_rvalue (new_el)); @@ -2733,6 +2734,7 @@ define_bool_to_lisp_obj (void) } /* Declare a function being compiled and add it to comp.exported_funcs_h. */ + static void declare_function (Lisp_Object func) { @@ -2823,7 +2825,7 @@ compile_function (Lisp_Object func) locals if the are not going to be used in a nargs call. This has two advantages: - Enable gcc for better reordering (frame array is clobbered every time is - passed as parameter being invoved into an nargs function call). + passed as parameter being involved into an nargs function call). - Allow gcc to trigger other optimizations that are prevented by memory referencing. */ @@ -2847,7 +2849,7 @@ compile_function (Lisp_Object func) comp.func_blocks_h = CALLN (Fmake_hash_table); - /* Pre declare all basic blocks to gcc. + /* Pre-declare all basic blocks to gcc. The "entry" block must be declared as first. */ declare_block (Qentry); Lisp_Object blocks = CALL1I (comp-func-blocks, func); @@ -2869,7 +2871,6 @@ compile_function (Lisp_Object func) xsignal1 (Qnative_ice, build_string ("basic block is missing or empty")); - comp.block = retrive_block (block_name); while (CONSP (insns)) { @@ -3139,10 +3140,10 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, /******************************************************************************/ -/* Helper functions called from the runtime. */ +/* Helper functions called from the run-time. */ /* These can't be statics till shared mechanism is used to solve relocations. */ /* Note: this are all potentially definable directly to gcc and are here just */ -/* for lazyness. Change this if a performance impact is measured. */ +/* for laziness. Change this if a performance impact is measured. */ /******************************************************************************/ Lisp_Object @@ -3356,9 +3357,10 @@ DEFUN ("native-elisp-load", Fnative_elisp_load, Snative_elisp_load, 1, 1, 0, void syms_of_comp (void) { - /* Compiler control customize. */ + /* Compiler control customizes. */ DEFSYM (Qcomp_speed, "comp-speed"); DEFSYM (Qcomp_debug, "comp-debug"); + /* Limple instruction set. */ DEFSYM (Qcomment, "comment"); DEFSYM (Qjump, "jump"); @@ -3371,7 +3373,7 @@ syms_of_comp (void) DEFSYM (Qcomp_mvar, "comp-mvar"); DEFSYM (Qcond_jump, "cond-jump"); DEFSYM (Qphi, "phi"); - /* In use for prologue emission. */ + /* Ops in use for prologue emission. */ DEFSYM (Qset_par_to_local, "set-par-to-local"); DEFSYM (Qset_args_to_local, "set-args-to-local"); DEFSYM (Qset_rest_args_to_local, "set-rest-args-to-local"); @@ -3383,7 +3385,7 @@ syms_of_comp (void) DEFSYM (Qfetch_handler, "fetch-handler"); DEFSYM (Qcondition_case, "condition-case"); /* call operands. */ - DEFSYM (Qcatcher, "catcher"); /* FIXME use these allover. */ + DEFSYM (Qcatcher, "catcher"); DEFSYM (Qentry, "entry"); DEFSYM (Qset_internal, "set_internal"); DEFSYM (Qrecord_unwind_current_buffer, "record_unwind_current_buffer"); @@ -3402,6 +3404,7 @@ syms_of_comp (void) DEFSYM (Qnegate, "negate"); DEFSYM (Qnumberp, "numberp"); DEFSYM (Qintegerp, "integerp"); + /* Others. */ DEFSYM (Qfixnum, "fixnum"); DEFSYM (Qadvice, "advice"); commit 954eb9b4a0b9d616db9646f081d11b2c6dd19581 Author: Andrea Corallo Date: Fri Nov 22 19:20:05 2019 +0100 homogeneous setf style diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index fffb845e4e..458c95a322 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -251,8 +251,8 @@ structure.") (defun comp-func-reset-generators (func) "Reset unique id generators for FUNC." - (setf (comp-func-edge-cnt-gen func) (comp-gen-counter)) - (setf (comp-func-ssa-cnt-gen func) (comp-gen-counter))) + (setf (comp-func-edge-cnt-gen func) (comp-gen-counter) + (comp-func-ssa-cnt-gen func) (comp-gen-counter))) (cl-defstruct (comp-mvar (:constructor make--comp-mvar)) "A meta-variable being a slot in the meta-stack." @@ -320,7 +320,7 @@ BODY is evaluate only if `comp-verbose' is > 0." (indent defun)) `(when (> comp-verbose 0) (with-current-buffer (get-buffer-create native-compile-log-buffer) - (setq buffer-read-only t) + (setf buffer-read-only t) (let ((inhibit-read-only t)) (goto-char (point-max)) ,@body)))) @@ -635,9 +635,9 @@ ENTRY-SP is the sp value when entering. The block is added to the current function. The block is returned." (let ((bb (make--comp-block addr entry-sp block-name))) - (setf (comp-limplify-curr-block comp-pass) bb) - (setf (comp-limplify-pc comp-pass) addr) - (setf (comp-limplify-sp comp-pass) (comp-block-sp bb)) + (setf (comp-limplify-curr-block comp-pass) bb + (comp-limplify-pc comp-pass) addr + (comp-limplify-sp comp-pass) (comp-block-sp bb)) (puthash (comp-block-name bb) bb (comp-func-blocks comp-func)) bb)) @@ -1127,9 +1127,9 @@ This will be called at load-time." (defun comp-limplify-block (bb) "Limplify basic-block BB and add it to the current function." - (setf (comp-limplify-curr-block comp-pass) bb) - (setf (comp-limplify-sp comp-pass) (comp-block-sp bb)) - (setf (comp-limplify-pc comp-pass) (comp-block-addr bb)) + (setf (comp-limplify-curr-block comp-pass) bb + (comp-limplify-sp comp-pass) (comp-block-sp bb) + (comp-limplify-pc comp-pass) (comp-block-addr bb)) (puthash (comp-block-name bb) bb (comp-func-blocks comp-func)) (cl-loop for inst-cell on (nthcdr (comp-limplify-pc comp-pass) @@ -1278,11 +1278,11 @@ Top level forms for the current context are rendered too." (finger2 (comp-block-post-num b2))) (while (not (= finger1 finger2)) (while (< finger1 finger2) - (setf b1 (comp-block-dom b1)) - (setf finger1 (comp-block-post-num b1))) + (setf b1 (comp-block-dom b1) + finger1 (comp-block-post-num b1))) (while (< finger2 finger1) - (setf b2 (comp-block-dom b2)) - (setf finger2 (comp-block-post-num b2)))) + (setf b2 (comp-block-dom b2) + finger2 (comp-block-post-num b2)))) b1)) (first-processed (l) (if-let ((p (cl-find-if (lambda (p) (comp-block-dom p)) l))) @@ -1314,8 +1314,8 @@ Top level forms for the current context are rendered too." when (comp-block-dom p) do (setf new-idom (intersect p new-idom))) unless (eq (comp-block-dom b) new-idom) - do (setf (comp-block-dom b) new-idom) - (setf changed t)))))) + do (setf (comp-block-dom b) new-idom + changed t)))))) (defun comp-compute-dominator-frontiers () "Compute the dominator frontier for each basic block in `comp-func'." @@ -1409,8 +1409,8 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non nil." (new-lvalue () ;; If is an assignment make a new mvar and put it as l-value. (let ((mvar (make-comp-ssa-mvar :slot slot-n))) - (setf (aref frame slot-n) mvar) - (setf (cadr insn) mvar)))) + (setf (aref frame slot-n) mvar + (cadr insn) mvar)))) (pcase insn (`(,(pred comp-assign-op-p) ,(pred targetp) . ,_) (let ((mvar (aref frame slot-n))) @@ -1499,9 +1499,9 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non nil." (while (consp insn) (let ((newcar (car insn))) (if (or (consp (car insn)) (comp-mvar-p (car insn))) - (setq newcar (comp-copy-insn (car insn)))) + (setf newcar (comp-copy-insn (car insn)))) (push newcar result)) - (setq insn (cdr insn))) + (setf insn (cdr insn))) (nconc (nreverse result) (if (comp-mvar-p insn) (comp-copy-insn insn) insn))) (if (comp-mvar-p insn) @@ -1778,7 +1778,7 @@ Prepare every function for final compilation and drive the C back-end." (let (compile-result) (comp--init-ctxt) (unwind-protect - (setq compile-result + (setf compile-result (comp-compile-ctxt-to-file (comp-ctxt-output comp-ctxt))) (and (comp--release-ctxt) compile-result)))) @@ -1826,10 +1826,10 @@ Prepare every function for final compilation and drive the C back-end." (when (comp-to-file-p f) (let* ((code `(progn (require 'comp) - (setq comp-speed ,comp-speed) - (setq comp-debug ,comp-debug) - (setq comp-verbose ,comp-verbose) - (setq load-path ',load-path) + (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))) (prc (start-process (concat "Compiling: " f) @@ -1866,7 +1866,7 @@ Return the compilation unit file name." (condition-case err (mapc (lambda (pass) (comp-log (format "Running pass %s:\n" pass) 2) - (setq data (funcall pass data))) + (setf data (funcall pass data))) comp-passes) (native-compiler-error ;; Add source input. commit 8ef0a1814eca5dc7f32e2784b3fa61498d220a70 Author: Andrea Corallo Date: Fri Nov 22 19:15:55 2019 +0100 better loop style into comp-compute-edges diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index ff091e6cde..fffb845e4e 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1244,16 +1244,15 @@ Top level forms for the current context are rendered too." (list "block does not end with a branch" bb (comp-func-symbol-name comp-func))))) - finally (progn - (setf (comp-func-edges comp-func) - (nreverse (comp-func-edges comp-func))) - ;; Update edge refs into blocks. - (cl-loop for edge in (comp-func-edges comp-func) - do (push edge - (comp-block-out-edges (comp-edge-src edge))) - (push edge - (comp-block-in-edges (comp-edge-dst edge)))) - (comp-log-edges comp-func))))) + finally (setf (comp-func-edges comp-func) + (nreverse (comp-func-edges comp-func))) + ;; Update edge refs into blocks. + (cl-loop for edge in (comp-func-edges comp-func) + do (push edge + (comp-block-out-edges (comp-edge-src edge))) + (push edge + (comp-block-in-edges (comp-edge-dst edge)))) + (comp-log-edges comp-func)))) (defun comp-collect-rev-post-order (basic-block) "Walk BASIC-BLOCK children and return their name in reversed post-order." commit 99258421bbb123e6f277610dcf94e022dde3a5c0 Author: Andrea Corallo Date: Fri Nov 22 19:15:12 2019 +0100 sanityze orthography in comp.el diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 5ebaf9f0f5..ff091e6cde 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -40,7 +40,7 @@ (defcustom comp-speed 0 "Compiler optimization level. From 0 to 3. -- 0 no otimizations are performed, compile time is favored. +- 0 no optimizations are performed, compile time is favored. - 1 lite optimizations. - 2 heavy optimizations. - 3 max optimization level, to be used only when necessary. @@ -50,8 +50,9 @@ (defcustom comp-debug 0 "Compiler debug level. From 0 to 3. +This intended for debugging the compiler itself. - 0 no debug facility. - This is the raccomanded value unless you are debugging the compiler itself. + This is the recommended value unless you are debugging the compiler itself. - 1 emit debug symbols and dump pseudo C code. - 2 dump gcc passes and libgccjit log file. - 3 dump libgccjit reproducers." @@ -60,6 +61,7 @@ (defcustom comp-verbose 0 "Compiler verbosity. From 0 to 3. +This intended for debugging the compiler itself. - 0 no logging. - 1 final limple is logged. - 2 LAP and final limple and some pass info are logged. @@ -92,7 +94,6 @@ Can be used by code that wants to expand differently in this case.") comp-final) "Passes to be executed in order.") -;; TODO hash here. (defconst comp-known-ret-types '((cons . cons) (1+ . number) (1- . number) @@ -119,7 +120,7 @@ Can be used by code that wants to expand differently in this case.") (defconst comp-limple-assignments `(fetch-handler ,@comp-limple-sets) - "Limple operators that clobbers the first mvar argument.") + "Limple operators that clobbers the first m-var argument.") (defconst comp-limple-calls '(call callref @@ -140,7 +141,7 @@ Can be used by code that wants to expand differently in this case.") (cl-defstruct comp-ctxt "Lisp side of the compiler context." (output nil :type string - :documentation "Target output filename for the compilation.") + :documentation "Target output file-name for the compilation.") (top-level-forms () :type list :documentation "List of spilled top level forms.") (funcs-h (make-hash-table) :type hash-table @@ -165,7 +166,7 @@ This is to build the prev field.") To be used when ncall-conv is nil.")) (cl-defstruct (comp-nargs (:include comp-args-base)) - "Describe args when the functin signature is of kind: + "Describe args when the function signature is of kind: (ptrdiff_t nargs, Lisp_Object *args)." (nonrest nil :type number :documentation "Number of non rest arguments.") @@ -191,7 +192,7 @@ into it.") (in-edges () :type list :documentation "List of incoming edges.") (out-edges () :type list - :documentation "List of outcoming edges.") + :documentation "List of out-coming edges.") (dom nil :type comp-block :documentation "Immediate dominator.") (df (make-hash-table) :type hash-table @@ -223,7 +224,7 @@ Is in use to help the SSA rename pass.")) (cl-defstruct (comp-func (:copier nil)) "LIMPLE representation of a function." (symbol-name nil - :documentation "Function symbol's name.") + :documentation "Function's symbol name.") (c-func-name nil :type string :documentation "The function name in the native world.") (byte-func nil @@ -259,16 +260,18 @@ structure.") :documentation "Slot number. -1 is a special value and indicates the scratch slot.") (id nil :type (or null number) - :documentation "SSA number.") + :documentation "SSA number when in SSA form.") (const-vld nil :type boolean :documentation "Valid signal for the following slot.") (constant nil - :documentation "When const-vld non nil this is used for constant - propagation.") + :documentation "When const-vld non nil this is used for holding + a value known at compile time.") (type nil - :documentation "When non nil is used for type propagation.") + :documentation "When non nil is used for type when known at compile + time.") (ref nil :type boolean - :documentation "When t this is used by reference.")) + :documentation "When t the m-var is involved in a call where is passed by + reference.")) ;; Special vars used by some passes (defvar comp-func) @@ -340,7 +343,8 @@ BODY is evaluate only if `comp-verbose' is > 0." (insert "\n")))))) (defun comp-log-func (func verbosity) - "Log function FUNC." + "Log function FUNC. +VERBOSITY is a number between 0 and 3." (when (>= comp-verbose verbosity) (comp-log (format "\nFunction: %s\n" (comp-func-symbol-name func)) verbosity) (cl-loop for block-name being each hash-keys of (comp-func-blocks func) @@ -462,7 +466,7 @@ Put PREFIX in front of it." collect func)) (defun comp-spill-lap (input) - "Byte compile and spill the LAP rapresentation for INPUT. + "Byte compile and spill the LAP representation for INPUT. If INPUT is a symbol this is the function-name to be compiled. If INPUT is a string this is the file path to be compiled." (let ((byte-native-compiling t) @@ -480,7 +484,7 @@ If INPUT is a string this is the file path to be compiled." (frame nil :type vector :documentation "Meta-stack used to flat LAP.") (curr-block nil :type comp-block - :documentation "Current block baing limplified.") + :documentation "Current block being limplified.") (sp -1 :type number :documentation "Current stack pointer while walking LAP. Points to the next slot to be filled.") @@ -570,7 +574,7 @@ The basic block is returned regardless it was already declared or not." `(call ,func ,@args)) (defun comp-callref (func nargs stack-off) - "Emit a call usign narg abi for FUNC. + "Emit a call using narg abi for FUNC. NARGS is the number of arguments. STACK-OFF is the index of the first slot frame involved." (comp-add-subr-to-relocs func) @@ -585,7 +589,8 @@ STACK-OFF is the index of the first slot frame involved." :type type)) (defun comp-new-frame (size &optional ssa) - "Return a clean frame of meta variables of size SIZE." + "Return a clean frame of meta variables of size SIZE. +If SSA non nil populate it of m-var in ssa form." (cl-loop with v = (make-vector size nil) for i below size for mvar = (if ssa @@ -715,7 +720,7 @@ Return value is the fall through block name." (defun comp-emit-switch (var last-insn) "Emit a limple for a lap jump table given VAR and LAST-INSN." - ;; FIXME this not efficent for big jump tables. We should have a second + ;; FIXME this not efficient for big jump tables. We should have a second ;; strategy for this case. (pcase last-insn (`(setimm ,_ ,_ ,jmp-table) @@ -785,8 +790,8 @@ SP-DELTA is the stack adjustment." (defun comp-body-eff (body op-name sp-delta) "Given the original body BODY compute the effective one. -When BODY is auto guess function name form the LAP bytecode -name. Othewise expect lname fnname." +When BODY is auto guess function name form the LAP byte-code +name. Otherwise expect lname fnname." (pcase (car body) ('auto (list `(comp-emit-set-call-subr @@ -799,7 +804,7 @@ name. Othewise expect lname fnname." (_ body)))) (defmacro comp-op-case (&rest cases) - "Expand CASES into the corresponding pcase. + "Expand CASES into the corresponding `pcase' expansion. This is responsible for generating the proper stack adjustment when known and the annotation emission." (declare (debug (body)) @@ -824,7 +829,7 @@ the annotation emission." (_ (signal 'native-ice (list "unexpected LAP op" (symbol-name op)))))) (defun comp-limplify-lap-inst (insn) - "Limplify LAP instruction INSN pushng it in the proper basic block." + "Limplify LAP instruction INSN pushing it in the proper basic block." (let ((op (car insn)) (arg (if (consp (cdr insn)) (cadr insn) @@ -1110,7 +1115,7 @@ This will be called at load-time." (defun comp-addr-to-bb-name (addr) "Search for a block starting at ADDR into pending or limplified blocks." - ;; FIXME: Actually we could have another hash for this. + ;; FIXME Actually we could have another hash for this. (cl-flet ((pred (bb) (equal (comp-block-addr bb) addr))) (if-let ((pending (cl-find-if #'pred @@ -1201,7 +1206,7 @@ Top level forms for the current context are rendered too." ;; plus placing the needed phis. ;; Because the number of phis placed is (supposed) to be the minimum necessary ;; this form is called 'minimal SSA form'. -;; This pass should be run every time basic blocks or mvar are shuffled. +;; This pass should be run every time basic blocks or m-var are shuffled. (cl-defun make-comp-ssa-mvar (&key slot (constant nil const-vld) type) (make--comp-mvar :id (funcall (comp-func-ssa-cnt-gen comp-func)) @@ -1251,7 +1256,7 @@ Top level forms for the current context are rendered too." (comp-log-edges comp-func))))) (defun comp-collect-rev-post-order (basic-block) - "Walk BASIC-BLOCK childs and return their name in reversed post-oder." + "Walk BASIC-BLOCK children and return their name in reversed post-order." (let ((visited (make-hash-table)) (acc ())) (cl-labels ((collect-rec (bb) @@ -1314,6 +1319,7 @@ Top level forms for the current context are rendered too." (setf changed t)))))) (defun comp-compute-dominator-frontiers () + "Compute the dominator frontier for each basic block in `comp-func'." ;; Originally based on: "A Simple, Fast Dominance Algorithm" ;; Cooper, Keith D.; Harvey, Timothy J.; Kennedy, Ken (2001). (cl-loop with blocks = (comp-func-blocks comp-func) @@ -1393,7 +1399,7 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non nil." (cl-defstruct (comp-ssa (:copier nil)) "Support structure used while SSA renaming." (frame (comp-new-frame (comp-func-frame-size comp-func) t) :type vector - :documentation "Vector of mvars.")) + :documentation "Vector of m-vars.")) (defun comp-ssa-rename-insn (insn frame) (dotimes (slot-n (comp-func-frame-size comp-func)) @@ -1419,7 +1425,7 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non nil." (setcdr insn (cl-nsubst-if mvar #'targetp (cdr insn))))))))) (defun comp-ssa-rename () - "Entry point to rename SSA within the current function." + "Entry point to rename into SSA within the current function." (comp-log "Renaming\n" 2) (let ((frame-size (comp-func-frame-size comp-func)) (visited (make-hash-table))) @@ -1442,7 +1448,7 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non nil." (defun comp-finalize-phis () "Fixup r-values into phis in all basic blocks." (cl-flet ((finalize-phi (args b) - ;; Concatenate into args all incoming mvars for this phi. + ;; Concatenate into args all incoming m-vars for this phi. (setcdr args (cl-loop with slot-n = (comp-mvar-slot (car args)) for e in (comp-block-in-edges b) @@ -1456,7 +1462,7 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non nil." do (finalize-phi args b))))) (defun comp-ssa (_) - "Port FUNCS into mininal SSA form." + "Port all functions into mininal SSA form." (maphash (lambda (_ f) (let ((comp-func f)) ;; TODO: if this is run more than once we should clean all CFG @@ -1475,8 +1481,8 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non nil." ;;; propagate pass specific code. ;; A very basic propagation pass follows. -;; This propagates values and types plus in the control flow graph. -;; Is also responsible for removing function calls to pure functions when +;; This propagates values and types plus ref property in the control flow graph. +;; This is also responsible for removing function calls to pure functions if ;; possible. (defsubst comp-strict-type-of (obj) @@ -1650,7 +1656,7 @@ Return t if something was changed." `(call ,callee ,@args))))))) (defun comp-call-optim-func () - "Perform trampoline call optimization for the current function." + "Perform the trampoline call optimization for the current function." (cl-loop with self = (comp-func-symbol-name comp-func) for b being each hash-value of (comp-func-blocks comp-func) @@ -1668,7 +1674,7 @@ Return t if something was changed." (setcar insn-cell new-form))))))) (defun comp-call-optim (_) - "Given FUNCS try to avoid funcall trampoline usage when possible." + "Try to optimize out funcall trampoline usage when possible." (when (>= comp-speed 2) (maphash (lambda (_ f) (let ((comp-func f)) @@ -1679,13 +1685,12 @@ Return t if something was changed." ;;; Dead code elimination pass specific code. ;; This simple pass try to eliminate insns became useful after propagation. ;; Even if gcc would take care of this is good to perform this here -;; in the hope of removing memory references (remember that most lisp -;; objects are loaded from the reloc array). +;; in the hope of removing memory references. ;; ;; This pass can be run as last optim. (defun comp-collect-mvar-ids (insn) - "Collect the mvar unique identifiers into INSN." + "Collect the m-var unique identifiers into INSN." (cl-loop for x in insn if (consp x) append (comp-collect-mvar-ids x) @@ -1698,7 +1703,7 @@ Return t if something was changed." Return the list of m-var ids nuked." (let ((l-vals ()) (r-vals ())) - ;; Collect used r and l values. + ;; Collect used r and l-values. (cl-loop for b being each hash-value of (comp-func-blocks comp-func) do (cl-loop @@ -1735,7 +1740,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 normals 'set'." +These are substituted with a normal 'set' op." (cl-loop for b being each hash-value of (comp-func-blocks comp-func) do (cl-loop @@ -1770,7 +1775,7 @@ Prepare every function for final compilation and drive the C back-end." (comp--compile-ctxt-to-file name)) (defun comp-final (_) - "Final pass driving DATA into the C back-end for code emission." + "Final pass driving the C back-end for code emission." (let (compile-result) (comp--init-ctxt) (unwind-protect @@ -1844,10 +1849,10 @@ Prepare every function for final compilation and drive the C back-end." ;;;###autoload (defun native-compile (input) "Compile INPUT into native code. -This is the entrypoint for the Emacs Lisp native compiler. +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. -Return the compilation unit filename." +Return the compilation unit file name." (unless (or (symbolp input) (stringp input)) (signal 'native-compiler-error @@ -1874,7 +1879,7 @@ Return the compilation unit filename." ;;;###autoload (defun native-compile-async (input &optional jobs recursively) - "Compile INPUT asyncronosly. + "Compile INPUT asynchronously. INPUT can be either a folder or a file. JOBS specifies the number of jobs (commands) to run simultaneously (1 default). Follow folders RECURSIVELY if non nil." commit d0e6a276643b2590eebf81e305b006c768653b10 Author: Andrea Corallo Date: Fri Nov 22 14:42:37 2019 +0100 better ert usage into tests diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 55570d48a3..a0e6e23cef 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -79,16 +79,12 @@ Check that the resulting binaries do not differ." (should (equal (comp-tests-list2-f 1 2 3) '(1 2 3))) (should (= (comp-tests-car-f '(1 . 2)) 1)) (should (null (comp-tests-car-f nil))) - (should (= (condition-case err - (comp-tests-car-f 3) - (error 10)) - 10)) + (should-error (comp-tests-car-f 3) + :type 'wrong-type-argument) (should (= (comp-tests-cdr-f '(1 . 2)) 2)) (should (null (comp-tests-cdr-f nil))) - (should (= (condition-case err - (comp-tests-cdr-f 3) - (error 10)) - 10)) + (should-error (comp-tests-cdr-f 3) + :type 'wrong-type-argument) (should (= (comp-tests-car-safe-f '(1 . 2)) 1)) (should (null (comp-tests-car-safe-f 'a))) (should (= (comp-tests-cdr-safe-f '(1 . 2)) 2)) @@ -191,24 +187,18 @@ Check that the resulting binaries do not differ." (should (= (comp-tests-fixnum-1-minus-f 10) 9)) (should (= (comp-tests-fixnum-1-minus-f most-negative-fixnum) (1- most-negative-fixnum))) - (should (equal (condition-case err - (comp-tests-fixnum-1-minus-f 'a) - (error err)) - '(wrong-type-argument number-or-marker-p a))) + (should-error (comp-tests-fixnum-1-minus-f 'a) + :type 'wrong-type-argument) (should (= (comp-tests-fixnum-1-plus-f 10) 11)) (should (= (comp-tests-fixnum-1-plus-f most-positive-fixnum) (1+ most-positive-fixnum))) - (should (equal (condition-case err - (comp-tests-fixnum-1-plus-f 'a) - (error err)) - '(wrong-type-argument number-or-marker-p a))) + (should-error (comp-tests-fixnum-1-plus-f 'a) + :type 'wrong-type-argument) (should (= (comp-tests-fixnum-minus-f 10) -10)) (should (= (comp-tests-fixnum-minus-f most-negative-fixnum) (- most-negative-fixnum))) - (should (equal (condition-case err - (comp-tests-fixnum-minus-f 'a) - (error err)) - '(wrong-type-argument number-or-marker-p a)))) + (should-error (comp-tests-fixnum-minus-f 'a) + :type 'wrong-type-argument)) (ert-deftest comp-tests-arith-comp () "Testing arithmetic comparisons." @@ -232,16 +222,10 @@ Check that the resulting binaries do not differ." "Testing setcar setcdr." (should (equal (comp-tests-setcar-f '(10 . 10) 3) '(3 . 10))) (should (equal (comp-tests-setcdr-f '(10 . 10) 3) '(10 . 3))) - (should (equal (condition-case - err - (comp-tests-setcar-f 3 10) - (error err)) - '(wrong-type-argument consp 3))) - (should (equal (condition-case - err - (comp-tests-setcdr-f 3 10) - (error err)) - '(wrong-type-argument consp 3)))) + (should-error (comp-tests-setcar-f 3 10) + :type 'wrong-type-argument) + (should-error (comp-tests-setcdr-f 3 10) + :type 'wrong-type-argument)) (ert-deftest comp-tests-bubble-sort () "Run bubble sort." commit 0bf55d3a8131da02999fe694caf34096d7408952 Author: Andrea Corallo Date: Fri Nov 22 14:00:02 2019 +0100 fix type hints error kind diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 666d467051..5ebaf9f0f5 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1789,10 +1789,12 @@ Prepare every function for final compilation and drive the C back-end." ;; are assumed just to be true. Use with extreme caution... (defun comp-hint-fixnum (x) - (cl-assert (fixnump x))) + (unless (fixnump x) + (signal 'wrong-type-argument x))) (defun comp-hint-cons (x) - (cl-assert (consp x))) + (unless (consp x) + (signal 'wrong-type-argument x))) ;; Some entry point support code. commit 71b363e2b3c709e64f8ef8ab7446cc3a19573eeb Author: Andrea Corallo Date: Thu Nov 21 16:09:30 2019 +0100 error handling rework diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index e1f0e65786..666d467051 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -389,7 +389,8 @@ Put PREFIX in front of it." (defun comp-decrypt-lambda-list (x) "Decript lambda list X." (unless (fixnump x) - (error "Can't native compile a non lexical scoped function")) + (signal 'native-compiler-error + "can't native compile a non lexical scoped function")) (let ((rest (not (= (logand x 128) 0))) (mandatory (logand x 127)) (nonrest (ash x -8))) @@ -409,7 +410,7 @@ Put PREFIX in front of it." (defun comp-spill-lap-function (_function-name) "Byte compile FUNCTION-NAME spilling data from the byte compiler." - (error "To be reimplemented") + (signal 'native-ice "to be reimplemented") ;; (let* ((f (symbol-function function-name)) ;; (func (make-comp-func :symbol-name function-name ;; :c-func-name (comp-c-func-name @@ -435,7 +436,7 @@ Put PREFIX in front of it." "Byte compile FILENAME spilling data from the byte compiler." (byte-compile-file filename) (unless byte-to-native-top-level-forms - (error "Empty byte compiler output")) + (signal 'native-compiler-error "empty byte compiler output")) (setf (comp-ctxt-top-level-forms comp-ctxt) (reverse byte-to-native-top-level-forms)) (cl-loop for f in (cl-loop for x in byte-to-native-top-level-forms ; All non anonymous. @@ -538,7 +539,7 @@ Restore the original value afterwards." (defsubst comp-label-to-addr (label) "Find the address of LABEL." (or (gethash label (comp-limplify-label-to-addr comp-pass)) - (error "Can't find label %d" label))) + (signal 'native-ice (list "label not found" label)))) (defsubst comp-mark-curr-bb-closed () "Mark the current basic block as closed." @@ -556,8 +557,9 @@ The basic block is returned regardless it was already declared or not." (comp-limplify-pending-blocks comp-pass))))) (if bb (progn - (cl-assert (or (null sp) (= sp (comp-block-sp bb))) - (sp (comp-block-sp bb)) "sp %d %d differs") + (unless (or (null sp) (= sp (comp-block-sp bb))) + (signal 'native-ice (list "incoherent stack pointers" + sp (comp-block-sp bb)))) bb) (car (push (make--comp-block lap-addr sp (comp-new-block-sym)) (comp-limplify-pending-blocks comp-pass)))))) @@ -607,7 +609,7 @@ If the callee function is known to have a return type propagate it." (defun comp-copy-slot (src-n &optional dst-n) "Set slot number DST-N to slot number SRC-N as source. If DST-N is specified use it otherwise assume it to be the current slot." - (comp-with-sp (if dst-n dst-n (comp-sp)) + (comp-with-sp (or dst-n (comp-sp)) (let ((src-slot (comp-slot-n src-n))) (cl-assert src-slot) (comp-emit `(set ,(comp-slot) ,src-slot))))) @@ -749,28 +751,28 @@ Return value is the fall through block name." ;; All fall through are artificially created here except the last one. (puthash ff-bb-name ff-bb (comp-func-blocks comp-func)) (setf (comp-limplify-curr-block comp-pass) ff-bb)))) - (_ (error "Missing previous setimm while creating a switch")))) + (_ (signal 'native-ice + "missing previous setimm while creating a switch")))) (defun comp-emit-set-call-subr (subr-name sp-delta) "Emit a call for SUBR-NAME. SP-DELTA is the stack adjustment." (let ((subr (symbol-function subr-name)) - (subr-str (symbol-name subr-name)) (nargs (1+ (- sp-delta)))) - (cl-assert (subrp subr) nil - "%s not a subr" subr-str) + (unless (subrp subr) + (signal 'native-ice (list "not a subr" subr))) (let* ((arity (subr-arity subr)) (minarg (car arity)) (maxarg (cdr arity))) - (cl-assert (not (eq maxarg 'unevalled)) nil - "%s contains unevalled arg" subr-name) + (when (eq maxarg 'unevalled) + (signal 'native-ice (list "subr contains unevalled args" subr-name))) (if (eq maxarg 'many) ;; callref case. (comp-emit-set-call (comp-callref subr-name nargs (comp-sp))) ;; Normal call. - (cl-assert (and (>= maxarg nargs) (<= minarg nargs)) - (nargs maxarg minarg) - "Incoherent stack adjustment %d, maxarg %d minarg %d") + (unless (and (>= maxarg nargs) (<= minarg nargs)) + (signal 'native-ice + (list "incoherent stack adjustment" nargs maxarg minarg))) (let* ((subr-name subr-name) (slots (cl-loop for i from 0 below maxarg collect (comp-slot-n (+ i (comp-sp)))))) @@ -817,9 +819,9 @@ the annotation emission." `(cl-incf (comp-sp) ,sp-delta)) ,@(comp-body-eff body op-name sp-delta)) else - collect `(',op (error ,(concat "Unsupported LAP op " - op-name)))) - (_ (error "Unexpected LAP op %s" (symbol-name op))))) + collect `(',op (signal 'native-ice + (list "unsupported LAP op" ',op-name)))) + (_ (signal 'native-ice (list "unexpected LAP op" (symbol-name op)))))) (defun comp-limplify-lap-inst (insn) "Limplify LAP instruction INSN pushng it in the proper basic block." @@ -1011,8 +1013,7 @@ the annotation emission." (cl-incf (comp-sp) (- 1 arg)) (comp-emit-set-call (comp-callref 'insert arg (comp-sp)))) (byte-stack-set - (comp-with-sp (1+ (comp-sp)) ;; FIXME!! - (comp-copy-slot (comp-sp) (- (comp-sp) arg)))) + (comp-copy-slot (1+ (comp-sp)) (- (comp-sp) arg -1))) (byte-stack-set2 (cl-assert nil)) ;; TODO (byte-discardN (cl-incf (comp-sp) (- arg))) @@ -1203,9 +1204,9 @@ Top level forms for the current context are rendered too." ;; This pass should be run every time basic blocks or mvar are shuffled. (cl-defun make-comp-ssa-mvar (&key slot (constant nil const-vld) type) - (make--comp-mvar :id (funcall (comp-func-ssa-cnt-gen comp-func)) - :slot slot :const-vld const-vld :constant constant - :type type)) + (make--comp-mvar :id (funcall (comp-func-ssa-cnt-gen comp-func)) + :slot slot :const-vld const-vld :constant constant + :type type)) (defun comp-compute-edges () "Compute the basic block edges for the current function." @@ -1234,8 +1235,10 @@ Top level forms for the current context are rendered too." (edge-add :src bb :dst (gethash forth blocks))) (return) (otherwise - (error "Block %s does not end with a branch in func %s" - bb (comp-func-symbol-name comp-func)))) + (signal 'native-ice + (list "block does not end with a branch" + bb + (comp-func-symbol-name comp-func))))) finally (progn (setf (comp-func-edges comp-func) (nreverse (comp-func-edges comp-func))) @@ -1280,7 +1283,7 @@ Top level forms for the current context are rendered too." (first-processed (l) (if-let ((p (cl-find-if (lambda (p) (comp-block-dom p)) l))) p - (error "Cant't find first preprocessed")))) + (signal 'native-ice "cant't find first preprocessed")))) (when-let ((blocks (comp-func-blocks comp-func)) (entry (gethash 'entry blocks)) @@ -1845,7 +1848,8 @@ If INPUT is a string, use it as the file path to be native compiled. Return the compilation unit filename." (unless (or (symbolp input) (stringp input)) - (error "Trying to native compile something not a symbol function or file")) + (signal 'native-compiler-error + (list "not a symbol function or file" input))) (let ((data input) (comp-native-compiling t) (comp-ctxt (make-comp-ctxt @@ -1858,7 +1862,12 @@ Return the compilation unit filename." (comp-log (format "Running pass %s:\n" pass) 2) (setq data (funcall pass data))) comp-passes) - (error (error "While compiling %s: %s" input (error-message-string err)))) + (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)))))) data)) ;;;###autoload @@ -1874,7 +1883,8 @@ Follow folders RECURSIVELY if non nil." (directory-files input t "\\.el$")) (if (file-exists-p input) (list input) - (error "Input not a file nor directory"))))) + (signal 'native-compiler-error + "input not a file nor directory"))))) (with-mutex comp-src-pool-mutex (setf comp-src-pool (nconc files comp-src-pool))) (cl-loop repeat jobs diff --git a/src/comp.c b/src/comp.c index f7950bcc72..61f297ea3d 100644 --- a/src/comp.c +++ b/src/comp.c @@ -70,14 +70,6 @@ along with GNU Emacs. If not, see . */ #endif #define SETJMP_NAME STR (SETJMP) -/* Raise an internal compiler error if test. - msg is evaluated only in that case. */ -#define ICE_IF(test, msg) \ - do { \ - if (test) \ - ice (msg); \ - } while (0) - /* C side of the compiler context. */ typedef struct { @@ -210,15 +202,6 @@ format_string (const char *format, ...) return scratch_area; } -static void -ice (const char* msg) -{ - if (msg) - xsignal1 (Qinternal_native_compiler_error, build_string (msg)); - else - xsignal0 (Qinternal_native_compiler_error); -} - static void bcall0 (Lisp_Object f) { @@ -273,7 +256,7 @@ type_to_cast_field (gcc_jit_type *type) else if (type == comp.lisp_obj_ptr_type) field = comp.cast_union_as_lisp_obj_ptr; else - ice ("unsupported cast"); + xsignal1 (Qnative_ice, build_string ("unsupported cast")); return field; } @@ -282,7 +265,9 @@ static gcc_jit_block * retrive_block (Lisp_Object block_name) { Lisp_Object value = Fgethash (block_name, comp.func_blocks_h, Qnil); - ICE_IF (NILP (value), "missing basic block"); + + if (NILP (value)) + xsignal1 (Qnative_ice, build_string ("missing basic block")); return (gcc_jit_block *) xmint_pointer (value); } @@ -293,8 +278,10 @@ declare_block (Lisp_Object block_name) char *name_str = SSDATA (SYMBOL_NAME (block_name)); gcc_jit_block *block = gcc_jit_function_new_block (comp.func, name_str); Lisp_Object value = make_mint_ptr (block); - ICE_IF (!NILP (Fgethash (block_name, comp.func_blocks_h, Qnil)), - "double basic block declaration"); + + if (!NILP (Fgethash (block_name, comp.func_blocks_h, Qnil))) + xsignal1 (Qnative_ice, build_string ("double basic block declaration")); + Fputhash (block_name, value, comp.func_blocks_h); } @@ -343,8 +330,10 @@ declare_imported_func (Lisp_Object subr_sym, gcc_jit_type *ret_type, int nargs, gcc_jit_type **types) { /* Don't want to declare the same function two times. */ - ICE_IF (!NILP (Fgethash (subr_sym, comp.imported_funcs_h, Qnil)), - "unexpected double function declaration"); + if (!NILP (Fgethash (subr_sym, comp.imported_funcs_h, Qnil))) + xsignal2 (Qnative_ice, + build_string ("unexpected double function declaration"), + subr_sym); if (nargs == MANY) { @@ -396,7 +385,10 @@ emit_call (Lisp_Object subr_sym, gcc_jit_type *ret_type, ptrdiff_t nargs, Lisp_Object func = Fgethash (subr_sym, direct ? comp.exported_funcs_h: comp.imported_funcs_h, Qnil); - ICE_IF (NILP (func), "missing function declaration"); + if (NILP (func)) + xsignal2 (Qnative_ice, + build_string ("missing function declaration"), + subr_sym); if (direct) { @@ -414,7 +406,10 @@ emit_call (Lisp_Object subr_sym, gcc_jit_type *ret_type, ptrdiff_t nargs, gcc_jit_lvalue_access_field (comp.func_relocs, NULL, (gcc_jit_field *) xmint_pointer (func)); - ICE_IF (!f_ptr, "undeclared function relocation"); + if (!f_ptr) + xsignal2 (Qnative_ice, + build_string ("missing function relocation"), + subr_sym); emit_comment (format_string ("calling subr: %s", SSDATA (SYMBOL_NAME (subr_sym)))); return gcc_jit_context_new_call_through_ptr (comp.ctxt, @@ -1092,7 +1087,11 @@ emit_set_internal (Lisp_Object args) #s(comp-mvar 6 1 t 3 nil)) */ /* TODO: Inline the most common case. */ - ICE_IF (list_length (args) != 3, "unexpected arg length for insns"); + if (list_length (args) != 3) + xsignal2 (Qnative_ice, + build_string ("unexpected arg length for insns"), + args); + args = XCDR (args); int i = 0; gcc_jit_rvalue *gcc_args[4]; @@ -1272,7 +1271,7 @@ emit_limple_insn (Lisp_Object insn) else if (EQ (handler_spec, Qcondition_case)) h_num = CONDITION_CASE; else - ice ("incoherent insn"); + xsignal2 (Qnative_ice, build_string ("incoherent insn"), insn); gcc_jit_rvalue *handler_type = gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.int_type, @@ -1372,9 +1371,13 @@ emit_limple_insn (Lisp_Object insn) else if (EQ (FIRST (arg1), Qdirect_callref)) res = emit_limple_call_ref (XCDR (arg1), true); else - ice ("LIMPLE inconsistent arg1 for op ="); + xsignal2 (Qnative_ice, + build_string ("LIMPLE inconsistent arg1 for insn"), + insn); - ICE_IF (!res, gcc_jit_context_get_first_error (comp.ctxt)); + if (!res) + xsignal1 (Qnative_ice, + build_string (gcc_jit_context_get_first_error (comp.ctxt))); emit_frame_assignment (arg[0], res); } @@ -1480,7 +1483,9 @@ emit_limple_insn (Lisp_Object insn) } else { - ice ("LIMPLE op inconsistent"); + xsignal2 (Qnative_ice, + build_string ("LIMPLE op inconsistent"), + op); } } @@ -2860,7 +2865,10 @@ compile_function (Lisp_Object func) Lisp_Object block_name = HASH_KEY (ht, i); Lisp_Object block = HASH_VALUE (ht, i); Lisp_Object insns = CALL1I (comp-block-insns, block); - ICE_IF (NILP (block) || NILP (insns), "basic block is missing or empty"); + if (NILP (block) || NILP (insns)) + xsignal1 (Qnative_ice, + build_string ("basic block is missing or empty")); + comp.block = retrive_block (block_name); while (CONSP (insns)) @@ -2871,10 +2879,12 @@ compile_function (Lisp_Object func) } } const char *err = gcc_jit_context_get_first_error (comp.ctxt); - ICE_IF (err, - format_string ("failing to compile function %s with error: %s", - SSDATA (SYMBOL_NAME (CALL1I (comp-func-symbol-name, func))), - err)); + if (err) + xsignal3 (Qnative_ice, + build_string ("failing to compile function"), + CALL1I (comp-func-symbol-name, func), + build_string (err)); + SAFE_FREE (); } @@ -2890,7 +2900,8 @@ DEFUN ("comp--init-ctxt", Fcomp__init_ctxt, Scomp__init_ctxt, { if (comp.ctxt) { - ice ("compiler context already taken"); + xsignal1 (Qnative_ice, + build_string ("compiler context already taken")); return Qnil; } @@ -3396,12 +3407,21 @@ syms_of_comp (void) DEFSYM (Qadvice, "advice"); /* To be signaled. */ - DEFSYM (Qinternal_native_compiler_error, "internal-native-compiler-error"); - Fput (Qinternal_native_compiler_error, Qerror_conditions, - pure_list (Qinternal_native_compiler_error, Qerror)); - Fput (Qinternal_native_compiler_error, Qerror_message, + + /* By the compiler. */ + DEFSYM (Qnative_compiler_error, "native-compiler-error"); + Fput (Qnative_compiler_error, Qerror_conditions, + pure_list (Qnative_compiler_error, Qerror)); + Fput (Qnative_compiler_error, Qerror_message, + build_pure_c_string ("Native compiler error")); + + DEFSYM (Qnative_ice, "native-ice"); + Fput (Qnative_ice, Qerror_conditions, + pure_list (Qnative_ice, Qnative_compiler_error, Qerror)); + Fput (Qnative_ice, Qerror_message, build_pure_c_string ("Internal native compiler error")); + /* By the load machinery. */ DEFSYM (Qnative_lisp_load_failed, "native-lisp-load-failed"); Fput (Qnative_lisp_load_failed, Qerror_conditions, pure_list (Qnative_lisp_load_failed, Qerror)); commit 23874aee8825a6f670b6c2da9eca2d9cf643b3af Author: Andrea Corallo Date: Wed Nov 20 22:37:09 2019 +0100 define internal-native-compiler-error as error diff --git a/src/comp.c b/src/comp.c index b3e6129751..f7950bcc72 100644 --- a/src/comp.c +++ b/src/comp.c @@ -214,9 +214,9 @@ static void ice (const char* msg) { if (msg) - error ("Internal native compiler error: %s", msg); + xsignal1 (Qinternal_native_compiler_error, build_string (msg)); else - error ("Internal native compiler error"); + xsignal0 (Qinternal_native_compiler_error); } static void @@ -3396,6 +3396,12 @@ syms_of_comp (void) DEFSYM (Qadvice, "advice"); /* To be signaled. */ + DEFSYM (Qinternal_native_compiler_error, "internal-native-compiler-error"); + Fput (Qinternal_native_compiler_error, Qerror_conditions, + pure_list (Qinternal_native_compiler_error, Qerror)); + Fput (Qinternal_native_compiler_error, Qerror_message, + build_pure_c_string ("Internal native compiler error")); + DEFSYM (Qnative_lisp_load_failed, "native-lisp-load-failed"); Fput (Qnative_lisp_load_failed, Qerror_conditions, pure_list (Qnative_lisp_load_failed, Qerror)); commit 4fe02acb6b0556c4b17c7a8e01f41698f5109512 Author: Andrea Corallo Date: Wed Nov 20 22:26:56 2019 +0100 better error handling while loading eln files diff --git a/src/comp.c b/src/comp.c index fc8ec40698..b3e6129751 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3209,9 +3209,8 @@ load_static_obj (dynlib_handle_ptr handle, const char *name) } static void -load_comp_unit (dynlib_handle_ptr handle, char *file_name) +load_comp_unit (dynlib_handle_ptr handle, Lisp_Object file) { - const char *err_msg; struct thread_state ***current_thread_reloc = dynlib_sym (handle, CURRENT_THREAD_RELOC_SYM); EMACS_INT ***pure_reloc = dynlib_sym (handle, PURE_RELOC_SYM); @@ -3224,10 +3223,7 @@ load_comp_unit (dynlib_handle_ptr handle, char *file_name) && data_relocs && f_relocs && top_level_run)) - { - err_msg = "inconsistent eln file."; - goto exit_error; - } + xsignal1 (Qnative_lisp_file_inconsistent, file); *current_thread_reloc = ¤t_thread; *pure_reloc = (EMACS_INT **)&pure; @@ -3255,14 +3251,10 @@ load_comp_unit (dynlib_handle_ptr handle, char *file_name) { subr = symbol_subr (f_sym); if (NILP (subr)) - { - /* FIXME: This is not robust in case of primitive - redefinition. */ - err_msg = format_string ("primitive %s redefined " - "or wrong relocation?", - f_str); - goto exit_error; - } + /* FIXME: This is not robust in case of primitive + redefinition. */ + xsignal2 (Qnative_lisp_wrong_reloc, f_sym, file); + f_relocs[i] = XSUBR (subr)->function.a0; } else if (!strcmp (f_str, "wrong_type_argument")) @@ -3290,20 +3282,13 @@ load_comp_unit (dynlib_handle_ptr handle, char *file_name) else if (!strcmp (f_str, "specbind")) f_relocs[i] = (void *) specbind; else - { - err_msg = format_string ("unexpected function relocation %s.", f_str); - goto exit_error; - } + xsignal2 (Qnative_lisp_wrong_reloc, f_sym, file); } /* Executing this will perform all the expected environment modification. */ top_level_run (); return; -exit_error: - xsignal1 (Qcomp_unit_load_failed, - build_string (format_string ("while loading %s, %s", - file_name, err_msg))); } DEFUN ("comp--register-subr", Fcomp__register_subr, @@ -3316,9 +3301,7 @@ DEFUN ("comp--register-subr", Fcomp__register_subr, { dynlib_handle_ptr handle = xmint_pointer (XCAR (load_handle_stack)); if (!handle) - xsignal1 (Qcomp_unit_load_failed, - build_string ("comp--register-subr can only be called during " - "native code load phase.")); + xsignal0 (Qwrong_register_subr_call); void *func = dynlib_sym (handle, SSDATA (c_name)); eassert (func); @@ -3349,9 +3332,9 @@ DEFUN ("native-elisp-load", Fnative_elisp_load, Snative_elisp_load, 1, 1, 0, dynlib_handle_ptr handle = dynlib_open (SSDATA (file)); load_handle_stack = Fcons (make_mint_ptr (handle), load_handle_stack); if (!handle) - xsignal2 (Qcomp_unit_load_failed, file, build_string (dynlib_error ())); + xsignal2 (Qnative_lisp_load_failed, file, build_string (dynlib_error ())); - load_comp_unit (handle, SSDATA (file)); + load_comp_unit (handle, file); load_handle_stack = XCDR (load_handle_stack); @@ -3408,12 +3391,36 @@ syms_of_comp (void) DEFSYM (Qnegate, "negate"); DEFSYM (Qnumberp, "numberp"); DEFSYM (Qintegerp, "integerp"); - /* To be signaled. */ - DEFSYM (Qcomp_unit_load_failed, "comp-unit-load-failed"); /* Others. */ DEFSYM (Qfixnum, "fixnum"); DEFSYM (Qadvice, "advice"); + /* To be signaled. */ + DEFSYM (Qnative_lisp_load_failed, "native-lisp-load-failed"); + Fput (Qnative_lisp_load_failed, Qerror_conditions, + pure_list (Qnative_lisp_load_failed, Qerror)); + Fput (Qnative_lisp_load_failed, Qerror_message, + build_pure_c_string ("Native elisp load failed")); + + DEFSYM (Qnative_lisp_wrong_reloc, "native-lisp-wrong-reloc"); + Fput (Qnative_lisp_wrong_reloc, Qerror_conditions, + pure_list (Qnative_lisp_wrong_reloc, Qnative_lisp_load_failed, Qerror)); + Fput (Qnative_lisp_wrong_reloc, Qerror_message, + build_pure_c_string ("Primitive redefined or wrong relocation")); + + DEFSYM (Qwrong_register_subr_call, "wrong-register-subr-call"); + Fput (Qwrong_register_subr_call, Qerror_conditions, + pure_list (Qwrong_register_subr_call, Qnative_lisp_load_failed, Qerror)); + Fput (Qwrong_register_subr_call, Qerror_message, + build_pure_c_string ("comp--register-subr can only be called during " + "native lisp load phase.")); + + DEFSYM (Qnative_lisp_file_inconsistent, "native-lisp-file-inconsistent"); + Fput (Qnative_lisp_file_inconsistent, Qerror_conditions, + pure_list (Qnative_lisp_file_inconsistent, Qnative_lisp_load_failed, Qerror)); + Fput (Qnative_lisp_file_inconsistent, Qerror_message, + build_pure_c_string ("inconsistent eln file")); + defsubr (&Scomp__init_ctxt); defsubr (&Scomp__release_ctxt); defsubr (&Scomp__compile_ctxt_to_file); commit 95eb82644d348c59af9f4ec10ad315bf5e498353 Author: Andrea Corallo Date: Wed Nov 20 21:51:11 2019 +0100 fix symbol_subr + better naming diff --git a/src/comp.c b/src/comp.c index 3e5f8f2990..fc8ec40698 100644 --- a/src/comp.c +++ b/src/comp.c @@ -228,15 +228,15 @@ bcall0 (Lisp_Object f) static Lisp_Object symbol_subr (Lisp_Object symbol) { - Lisp_Object subr = Fsymbol_function (symbol); + Lisp_Object maybe_subr = Fsymbol_function (symbol); - if (SUBRP (subr)) - return subr; + if (SUBRP (maybe_subr)) + return maybe_subr; - if (!NILP (CALL1I (ad-has-any-advice, symbol))) - subr = CALL1I (ad-get-orig-definition, symbol); + if (!NILP (CALL1I (advice--p, maybe_subr))) + maybe_subr = CALL1I (ad-get-orig-definition, symbol); - return SUBRP (subr) ? subr : Qnil; + return SUBRP (maybe_subr) ? maybe_subr : Qnil; } static gcc_jit_field * commit eae7f30a9a338b5713d7808c9f791e1a7f79b3cf Author: Andrea Corallo Date: Wed Nov 20 19:37:47 2019 +0100 comment nit diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 2ee244077b..e1f0e65786 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1691,7 +1691,7 @@ Return t if something was changed." collect (comp-mvar-id x))) (defun comp-dead-assignments-func () - "Clean-up trivial dead assignments into current function. + "Clean-up dead assignments into current function. Return the list of m-var ids nuked." (let ((l-vals ()) (r-vals ())) commit 630fcab4fcfa9afab4688d803892d76cf6f46961 Author: Andrea Corallo Date: Wed Nov 20 19:13:57 2019 +0100 fix missing goto into load_comp_unit diff --git a/src/comp.c b/src/comp.c index e604c31c5f..3e5f8f2990 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3290,7 +3290,10 @@ load_comp_unit (dynlib_handle_ptr handle, char *file_name) else if (!strcmp (f_str, "specbind")) f_relocs[i] = (void *) specbind; else - err_msg = format_string ("unexpected function relocation %s.", f_str); + { + err_msg = format_string ("unexpected function relocation %s.", f_str); + goto exit_error; + } } /* Executing this will perform all the expected environment modification. */ commit 37989f9431bc32f7ebac76cfc02f5e1d03486bcf Author: Andrea Corallo Date: Tue Nov 19 21:53:19 2019 +0100 remove unsigned in favor of ptrdiff_t diff --git a/src/comp.c b/src/comp.c index 31f6c8dbd2..e604c31c5f 100644 --- a/src/comp.c +++ b/src/comp.c @@ -362,7 +362,7 @@ declare_imported_func (Lisp_Object subr_sym, gcc_jit_type *ret_type, else if (!types) { types = alloca (nargs * sizeof (* types)); - for (unsigned i = 0; i < nargs; i++) + for (ptrdiff_t i = 0; i < nargs; i++) types[i] = comp.lisp_obj_type; } @@ -390,7 +390,7 @@ declare_imported_func (Lisp_Object subr_sym, gcc_jit_type *ret_type, /* Emit calls fetching from existing declarations. */ static gcc_jit_rvalue * -emit_call (Lisp_Object subr_sym, gcc_jit_type *ret_type, unsigned nargs, +emit_call (Lisp_Object subr_sym, gcc_jit_type *ret_type, ptrdiff_t nargs, gcc_jit_rvalue **args, bool direct) { Lisp_Object func = @@ -426,7 +426,7 @@ emit_call (Lisp_Object subr_sym, gcc_jit_type *ret_type, unsigned nargs, } static gcc_jit_rvalue * -emit_call_ref (Lisp_Object subr_sym, unsigned nargs, +emit_call_ref (Lisp_Object subr_sym, ptrdiff_t nargs, gcc_jit_lvalue *base_arg, bool direct) { gcc_jit_rvalue *args[] = @@ -468,7 +468,7 @@ emit_cond_jump (gcc_jit_rvalue *test, static gcc_jit_rvalue * emit_cast (gcc_jit_type *new_type, gcc_jit_rvalue *obj) { - static unsigned i; + static ptrdiff_t i; gcc_jit_field *orig_field = type_to_cast_field (gcc_jit_rvalue_get_type (obj)); @@ -478,7 +478,7 @@ emit_cast (gcc_jit_type *new_type, gcc_jit_rvalue *obj) gcc_jit_function_new_local (comp.func, NULL, comp.cast_union_type, - format_string ("union_cast_%u", i++)); + format_string ("union_cast_%td", i++)); gcc_jit_block_add_assignment (comp.block, NULL, gcc_jit_lvalue_access_field (tmp_u, @@ -566,7 +566,7 @@ emit_lval_XLP (gcc_jit_lvalue *obj) comp.lisp_obj_as_ptr); } */ static gcc_jit_rvalue * -emit_XUNTAG (gcc_jit_rvalue *a, gcc_jit_type *type, unsigned lisp_word_tag) +emit_XUNTAG (gcc_jit_rvalue *a, gcc_jit_type *type, ptrdiff_t lisp_word_tag) { /* #define XUNTAG(a, type, ctype) ((ctype *) ((char *) XLP (a) - LISP_WORD_TAG (type))) */ @@ -608,7 +608,7 @@ emit_EQ (gcc_jit_rvalue *x, gcc_jit_rvalue *y) } static gcc_jit_rvalue * -emit_TAGGEDP (gcc_jit_rvalue *obj, unsigned tag) +emit_TAGGEDP (gcc_jit_rvalue *obj, ptrdiff_t tag) { /* (! (((unsigned) (XLI (a) >> (USE_LSB_TAG ? 0 : VALBITS)) \ - (unsigned) (tag)) \ @@ -1211,7 +1211,7 @@ emit_limple_insn (Lisp_Object insn) Lisp_Object arg[6]; Lisp_Object p = XCDR (insn); - unsigned i = 0; + ptrdiff_t i = 0; FOR_EACH_TAIL (p) { if (i == sizeof (arg) / sizeof (Lisp_Object)) @@ -2428,7 +2428,7 @@ define_add1_sub1 (void) { comp.most_positive_fixnum, comp.most_negative_fixnum }; enum gcc_jit_binary_op op[] = { GCC_JIT_BINARY_OP_PLUS, GCC_JIT_BINARY_OP_MINUS }; - for (unsigned i = 0; i < 2; i++) + for (ptrdiff_t i = 0; i < 2; i++) { gcc_jit_param *param[] = { gcc_jit_context_new_param (comp.ctxt, @@ -2741,7 +2741,7 @@ declare_function (Lisp_Object func) { EMACS_INT max_args = XFIXNUM (CALL1I (comp-args-max, args)); gcc_jit_type **type = SAFE_ALLOCA (max_args * sizeof (*type)); - for (unsigned i = 0; i < max_args; i++) + for (ptrdiff_t i = 0; i < max_args; i++) type[i] = comp.lisp_obj_type; gcc_jit_param **param = SAFE_ALLOCA (max_args *sizeof (*param)); @@ -2825,12 +2825,12 @@ compile_function (Lisp_Object func) if (SPEED >= 2) { comp.f_frame = SAFE_ALLOCA (frame_size * sizeof (*comp.f_frame)); - for (unsigned i = 0; i < frame_size; ++i) + for (ptrdiff_t i = 0; i < frame_size; ++i) comp.f_frame[i] = gcc_jit_function_new_local (comp.func, NULL, comp.lisp_obj_type, - format_string ("local%u", i)); + format_string ("local%td", i)); } comp.scratch = NULL; commit e97826ab845597fe09be43b2df888e96c7502bee Author: Andrea Corallo Date: Tue Nov 19 21:35:18 2019 +0100 remove native-load-history diff --git a/src/comp.c b/src/comp.c index 3687bdb86a..31f6c8dbd2 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3343,8 +3343,6 @@ DEFUN ("native-elisp-load", Fnative_elisp_load, Snative_elisp_load, 1, 1, 0, Frequire (Qadvice, Qnil, Qnil); - Vnative_load_history = Fcons (file, Vnative_load_history); - dynlib_handle_ptr handle = dynlib_open (SSDATA (file)); load_handle_stack = Fcons (make_mint_ptr (handle), load_handle_stack); if (!handle) @@ -3431,10 +3429,6 @@ syms_of_comp (void) doc: /* The compiler context. */); Vcomp_ctxt = Qnil; - DEFVAR_LISP ("native-load-history", Vnative_load_history, - doc: /* List with the history of the eln loaded. */); - Vnative_load_history = Qnil; - /* Load mechanism. */ staticpro (&Vnative_elisp_refs_hash); Vnative_elisp_refs_hash commit 0c60b3bae71a010e6abdcfd4d8d38b92c7874609 Author: Andrea Corallo Date: Tue Nov 19 21:26:45 2019 +0100 fix comp-tests-bootstrap diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index b008dbd574..55570d48a3 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -29,6 +29,9 @@ (require 'cl-lib) (require 'comp) +;; (setq comp-debug 1) +(setq comp-speed 3) + (defconst comp-test-directory (file-name-directory (or load-file-name buffer-file-name))) (defconst comp-test-src @@ -40,25 +43,27 @@ (ert-deftest comp-tests-bootstrap () "Compile the compiler and load it to compile it-self. Check that the resulting binaries do not differ." - (let ((comp-file (concat comp-test-directory + (let* ((comp-src (concat comp-test-directory "../../lisp/emacs-lisp/comp.el")) - (comp1-file (concat temporary-file-directory + (comp1-src (concat temporary-file-directory (make-temp-name "stage1-") ".el")) - (comp2-file (concat temporary-file-directory + (comp2-src (concat temporary-file-directory (make-temp-name "stage2-") - ".el"))) - (copy-file comp-file comp1-file) - (copy-file comp-file comp2-file) - (load (concat comp-file "c") nil nil t t) + ".el")) + (comp1 (concat comp1-src "n")) + (comp2 (concat comp2-src "n"))) + (copy-file comp-src comp1-src) + (copy-file comp-src comp2-src) + (load (concat comp-src "c") nil nil t t) (should (null (subr-native-elisp-p (symbol-function #'native-compile)))) (message "Compiling stage1...") - (load (native-compile comp1-file) nil nil t t) + (load (native-compile comp1-src) nil nil t t) (should (subr-native-elisp-p (symbol-function 'native-compile))) (message "Compiling stage2...") - (native-compile comp2-file) - (message "Comparing %s %s" comp1-file comp2-file) - (should (= (call-process "cmp" nil nil nil comp1-file comp2-file) 0)))) + (native-compile comp2-src) + (message "Comparing %s %s" comp1 comp2) + (should (= (call-process "cmp" nil nil nil comp1 comp2) 0)))) (ert-deftest comp-tests-provide () "Testing top level provide." commit ab5611c25b92ca06238de3d0ae53226176c2ae0d Author: Andrea Corallo Date: Tue Nov 19 20:50:18 2019 +0100 fix comp-propagate* diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 7408034b93..2ee244077b 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1571,7 +1571,7 @@ Return t if something was changed." do (comp-propagate-insn insn) when (and (null modified) (not (equal insn orig-insn))) do (setf modified t)) - finally (cl-return modified))) + finally return modified)) (defun comp-propagate (_) (maphash (lambda (_ f) commit 407f5aac70f1481dfb365db7ba2e435f439498d0 Author: Andrea Corallo Date: Tue Nov 19 20:49:51 2019 +0100 better comp-function-call-remove diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 073af957be..7408034b93 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1524,8 +1524,9 @@ This can run just once." (when (and (get f 'pure) ; Can we just optimize pure here? See byte-opt.el (cl-every #'comp-mvar-const-vld args)) (let ((val (apply f (mapcar #'comp-mvar-constant args)))) + ;; See `comp-emit-set-const'. (setf (car insn) 'setimm - (caddr insn) (comp-add-const-to-relocs val))))) + (cddr insn) (list (comp-add-const-to-relocs val) val))))) (defun comp-propagate-insn (insn) "Propagate within INSN." commit 3681402bf163a3b5a7b7642f553e87693028649e Author: Andrea Corallo Date: Tue Nov 19 20:27:27 2019 +0100 improve dead assignment diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index b6a3662ec5..073af957be 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1684,13 +1684,14 @@ Return t if something was changed." "Collect the mvar unique identifiers into INSN." (cl-loop for x in insn if (consp x) - append (comp-collect-mvar-ids x) + append (comp-collect-mvar-ids x) else - when (comp-mvar-p x) - collect (comp-mvar-id x))) + when (comp-mvar-p x) + collect (comp-mvar-id x))) (defun comp-dead-assignments-func () - "Clean-up dead assignments into current function." + "Clean-up trivial dead assignments into current function. +Return the list of m-var ids nuked." (let ((l-vals ()) (r-vals ())) ;; Collect used r and l values. @@ -1725,7 +1726,8 @@ Return t if something was changed." (if (comp-limple-insn-call-p rest) rest `(comment ,(format "optimized out: %s" - insn))))))))) + insn)))))) + nuke-list))) (defun comp-remove-type-hints-func () "Remove type hints from the current function. @@ -1744,7 +1746,11 @@ These are substituted with normals 'set'." (when (>= comp-speed 2) (maphash (lambda (_ f) (let ((comp-func f)) - (comp-dead-assignments-func) + (cl-loop + for i from 1 + while (comp-dead-assignments-func) + finally (comp-log (format "dead code rm run %d times\n" i) 2) + (comp-log-func comp-func 3)) (comp-remove-type-hints-func) (comp-log-func comp-func 3))) (comp-ctxt-funcs-h comp-ctxt)))) commit 16fe8a4678d20eac893bd05941071396b67bc84d Author: Andrea Corallo Date: Mon Nov 18 19:35:44 2019 +0100 allow for pure function call removal optimization diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index f805540fcd..b6a3662ec5 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1472,6 +1472,9 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non nil." ;;; propagate pass specific code. ;; A very basic propagation pass follows. +;; This propagates values and types plus in the control flow graph. +;; Is also responsible for removing function calls to pure functions when +;; possible. (defsubst comp-strict-type-of (obj) "Given OBJ return its type understanding fixnums." @@ -1506,29 +1509,39 @@ This can run just once." for insn in (comp-block-insns b) do (pcase insn (`(setimm ,lval ,_ ,v) - (setf (comp-mvar-const-vld lval) t) - (setf (comp-mvar-constant lval) v) - (setf (comp-mvar-type lval) (comp-strict-type-of v))))))) + (setf (comp-mvar-const-vld lval) t + (comp-mvar-constant lval) v + (comp-mvar-type lval) (comp-strict-type-of v))))))) (defsubst comp-mvar-propagate (lval rval) "Propagate into LVAL properties of RVAL." - (setf (comp-mvar-const-vld lval) (comp-mvar-const-vld rval)) - (setf (comp-mvar-constant lval) (comp-mvar-constant rval)) - (setf (comp-mvar-type lval) (comp-mvar-type rval))) + (setf (comp-mvar-const-vld lval) (comp-mvar-const-vld rval) + (comp-mvar-constant lval) (comp-mvar-constant rval) + (comp-mvar-type lval) (comp-mvar-type rval))) + +(defsubst comp-function-call-remove (insn f args) + "Given INSN when F is pure if all ARGS are known remove the function call." + (when (and (get f 'pure) ; Can we just optimize pure here? See byte-opt.el + (cl-every #'comp-mvar-const-vld args)) + (let ((val (apply f (mapcar #'comp-mvar-constant args)))) + (setf (car insn) 'setimm + (caddr insn) (comp-add-const-to-relocs val))))) (defun comp-propagate-insn (insn) "Propagate within INSN." (pcase insn (`(set ,lval ,rval) (pcase rval - (`(,(or 'call 'direct-call) ,f . ,_) + (`(,(or 'call 'direct-call) ,f . ,args) (setf (comp-mvar-type lval) - (alist-get f comp-known-ret-types))) + (alist-get f comp-known-ret-types)) + (comp-function-call-remove insn f args)) (`(,(or 'callref 'direct-callref) ,f . ,args) (cl-loop for v in args do (setf (comp-mvar-ref v) t)) (setf (comp-mvar-type lval) - (alist-get f comp-known-ret-types))) + (alist-get f comp-known-ret-types)) + (comp-function-call-remove insn f args)) (_ (comp-mvar-propagate lval rval)))) (`(phi ,lval . ,rest) diff --git a/test/src/comp-test-funcs.el b/test/src/comp-test-funcs.el index ca604b748f..20d15ac0e7 100644 --- a/test/src/comp-test-funcs.el +++ b/test/src/comp-test-funcs.el @@ -252,6 +252,11 @@ (defun comp-tests-signal-f () (signal 'foo t)) +(defun comp-tests-func-call-removal-f () + (let ((a 10) + (b 3)) + (% a b))) + ;;;;;;;;;;;;;;;;;;;; ;; Tromey's tests ;; diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 0a1d45724f..b008dbd574 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -317,6 +317,11 @@ Check that the resulting binaries do not differ." (comp-tests-signal-f) (t err)) '(foo . t)))) + +(ert-deftest comp-tests-func-call-removal () + ;; See `comp-propagate-insn' `comp-function-call-remove'. + (should (= (comp-tests-func-call-removal-f) 1))) + ;;;;;;;;;;;;;;;;;;;; ;; Tromey's tests ;; commit a99a3fbc40076aa3965feb759e816a8a25621c6a Author: Andrea Corallo Date: Mon Nov 18 00:05:55 2019 +0100 fix jump table emission when test fn is not eq diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 859e0dedd9..f805540fcd 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -256,7 +256,8 @@ structure.") (cl-defstruct (comp-mvar (:constructor make--comp-mvar)) "A meta-variable being a slot in the meta-stack." (slot nil :type fixnum - :documentation "Slot number.") + :documentation "Slot number. +-1 is a special value and indicates the scratch slot.") (id nil :type (or null number) :documentation "SSA number.") (const-vld nil :type boolean @@ -712,12 +713,15 @@ Return value is the fall through block name." (defun comp-emit-switch (var last-insn) "Emit a limple for a lap jump table given VAR and LAST-INSN." + ;; FIXME this not efficent for big jump tables. We should have a second + ;; strategy for this case. (pcase last-insn - (`(setimm ,_ ,_ ,const) + (`(setimm ,_ ,_ ,jmp-table) (cl-loop - for test being each hash-keys of const + for test being each hash-keys of jmp-table using (hash-value target-label) - with len = (hash-table-count const) + with len = (hash-table-count jmp-table) + with test-func = (hash-table-test jmp-table) for n from 1 for last = (= n len) for m-test = (make-comp-mvar :constant test) @@ -730,12 +734,21 @@ Return value is the fall through block name." (comp-sp) (comp-new-block-sym))) for ff-bb-name = (comp-block-name ff-bb) - do - (comp-emit (list 'cond-jump var m-test ff-bb-name target-name)) - (unless last - ;; All fall through are artificially created here except the last one. - (puthash ff-bb-name ff-bb (comp-func-blocks comp-func)) - (setf (comp-limplify-curr-block comp-pass) ff-bb)))) + if (eq test-func 'eq) + do (comp-emit (list 'cond-jump var m-test ff-bb-name target-name)) + else + ;; Store the result of the comparison into the scratch slot before + ;; emitting the conditional jump. + do (comp-emit (list 'set (make-comp-mvar :slot -1) + (comp-call test-func var m-test))) + (comp-emit (list 'cond-jump + (make-comp-mvar :slot -1) + (make-comp-mvar :constant nil) + target-name ff-bb-name)) + do (unless last + ;; All fall through are artificially created here except the last one. + (puthash ff-bb-name ff-bb (comp-func-blocks comp-func)) + (setf (comp-limplify-curr-block comp-pass) ff-bb)))) (_ (error "Missing previous setimm while creating a switch")))) (defun comp-emit-set-call-subr (subr-name sp-delta) diff --git a/src/comp.c b/src/comp.c index 8001580eba..3687bdb86a 100644 --- a/src/comp.c +++ b/src/comp.c @@ -146,6 +146,7 @@ typedef struct { gcc_jit_block *block; /* Current basic block being compiled. */ gcc_jit_lvalue **frame; /* Frame for the current function. */ gcc_jit_lvalue **f_frame; /* "Floating" frame for the current function. */ + gcc_jit_lvalue *scratch; /* Used as scratch slot for some code sequence (switch). */ gcc_jit_rvalue *most_positive_fixnum; gcc_jit_rvalue *most_negative_fixnum; gcc_jit_rvalue *one; @@ -301,6 +302,15 @@ static gcc_jit_lvalue * get_slot (Lisp_Object mvar) { EMACS_INT slot_n = XFIXNUM (CALL1I (comp-mvar-slot, mvar)); + if (slot_n == -1) + { + if (!comp.scratch) + comp.scratch = gcc_jit_function_new_local (comp.func, + NULL, + comp.lisp_obj_type, + "scratch"); + return comp.scratch; + } gcc_jit_lvalue **frame = (CALL1I (comp-mvar-ref, mvar) || SPEED < 2) ? comp.frame : comp.f_frame; @@ -2823,6 +2833,8 @@ compile_function (Lisp_Object func) format_string ("local%u", i)); } + comp.scratch = NULL; + comp.loc_handler = gcc_jit_function_new_local (comp.func, NULL, comp.handler_ptr_type, commit 42b08f8a9ada7791c992894e88f648909e1ecc95 Author: Andrea Corallo Date: Sun Nov 17 23:23:50 2019 +0100 some style nits diff --git a/src/comp.c b/src/comp.c index 251ba242d4..8001580eba 100644 --- a/src/comp.c +++ b/src/comp.c @@ -398,20 +398,21 @@ emit_call (Lisp_Object subr_sym, gcc_jit_type *ret_type, unsigned nargs, nargs, args); } - else { - gcc_jit_lvalue *f_ptr = - gcc_jit_lvalue_access_field (comp.func_relocs, - NULL, - (gcc_jit_field *) xmint_pointer (func)); - ICE_IF (!f_ptr, "undeclared function relocation"); - emit_comment (format_string ("calling subr: %s", - SSDATA (SYMBOL_NAME (subr_sym)))); - return gcc_jit_context_new_call_through_ptr (comp.ctxt, - NULL, - gcc_jit_lvalue_as_rvalue (f_ptr), - nargs, - args); - } + else + { + gcc_jit_lvalue *f_ptr = + gcc_jit_lvalue_access_field (comp.func_relocs, + NULL, + (gcc_jit_field *) xmint_pointer (func)); + ICE_IF (!f_ptr, "undeclared function relocation"); + emit_comment (format_string ("calling subr: %s", + SSDATA (SYMBOL_NAME (subr_sym)))); + return gcc_jit_context_new_call_through_ptr (comp.ctxt, + NULL, + gcc_jit_lvalue_as_rvalue (f_ptr), + nargs, + args); + } } static gcc_jit_rvalue * @@ -481,8 +482,7 @@ emit_cast (gcc_jit_type *new_type, gcc_jit_rvalue *obj) } /* - Emit the equivalent of - + Emit the equivalent of: (typeof_ptr) ((uintptr) ptr + size_of_ptr_ref * i) */ @@ -1046,8 +1046,8 @@ emit_mvar_val (Lisp_Object mvar) { if (FIXNUMP (constant)) { - /* We can still emit directly objects that are selfcontained in a word - (read fixnums). */ + /* We can still emit directly objects that are self-contained in a + word (read fixnums). */ emit_comment (SSDATA (Fprin1_to_string (constant, Qnil))); gcc_jit_rvalue *word = gcc_jit_context_new_rvalue_from_ptr (comp.ctxt, @@ -1168,7 +1168,7 @@ emit_limple_push_handler (gcc_jit_rvalue *handler, gcc_jit_rvalue *handler_type, gcc_jit_block *handler_bb, gcc_jit_block *guarded_bb, Lisp_Object clobbered_mvar) { - /* struct handler *c = push_handler (POP, type); */ + /* struct handler *c = push_handler (POP, type); */ gcc_jit_rvalue *args[] = { handler, handler_type }; gcc_jit_block_add_assignment ( commit 41bfb91f5db878d139d5c0c631c569475018a7c2 Author: Andrea Corallo Date: Sun Nov 17 08:16:53 2019 +0100 add comp-tests-jump-table-2-f diff --git a/test/src/comp-test-funcs.el b/test/src/comp-test-funcs.el index 3ba12dc2a6..ca604b748f 100644 --- a/test/src/comp-test-funcs.el +++ b/test/src/comp-test-funcs.el @@ -111,6 +111,11 @@ ('y 'b) (_ 'c))) +(defun comp-tests-jump-table-2-f (x) + (pcase x + ("aaa" 'a) + ("bbb" 'b))) + (defun comp-tests-conditionals-1-f (x) ;; Generate goto-if-nil (if x 1 2)) diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index a76a4a8c46..0a1d45724f 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -168,7 +168,11 @@ Check that the resulting binaries do not differ." "Testing jump tables" (should (eq (comp-tests-jump-table-1-f 'x) 'a)) (should (eq (comp-tests-jump-table-1-f 'y) 'b)) - (should (eq (comp-tests-jump-table-1-f 'xxx) 'c))) + (should (eq (comp-tests-jump-table-1-f 'xxx) 'c)) + + ;; Jump table not with eq as test + (should (eq (comp-tests-jump-table-2-f "aaa") 'a)) + (should (eq (comp-tests-jump-table-2-f "bbb") 'b))) (ert-deftest comp-tests-conditionals () "Testing conditionals." commit 77c9236957a195a4ad0f50e8f19653a5c6918c8e Author: Andrea Corallo Date: Sun Nov 17 07:26:14 2019 +0100 add comp-tests-signal diff --git a/test/src/comp-test-funcs.el b/test/src/comp-test-funcs.el index 214e07e6dd..3ba12dc2a6 100644 --- a/test/src/comp-test-funcs.el +++ b/test/src/comp-test-funcs.el @@ -244,6 +244,10 @@ (defun comp-tests-trampoline-removal-f () (make-hash-table)) +(defun comp-tests-signal-f () + (signal 'foo t)) + + ;;;;;;;;;;;;;;;;;;;; ;; Tromey's tests ;; ;;;;;;;;;;;;;;;;;;;; diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 2a4c849a7c..a76a4a8c46 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -308,6 +308,12 @@ Check that the resulting binaries do not differ." ;; At speed >= 2 the trampoline will not be used. (should (hash-table-p (comp-tests-trampoline-removal-f)))) +(ert-deftest comp-tests-signal () + (should (equal (condition-case err + (comp-tests-signal-f) + (t err)) + '(foo . t)))) + ;;;;;;;;;;;;;;;;;;;; ;; Tromey's tests ;; ;;;;;;;;;;;;;;;;;;;; commit 41e5c9400cd9eeeecff2262907c09c3b10a5cde7 Author: Andrea Corallo Date: Sun Nov 17 19:25:21 2019 +0100 require advice when compiling or loading diff --git a/src/comp.c b/src/comp.c index ad669a5daf..251ba242d4 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3052,6 +3052,8 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, { CHECK_STRING (ctxtname); + Frequire (Qadvice, Qnil, Qnil); + gcc_jit_context_set_int_option (comp.ctxt, GCC_JIT_INT_OPTION_OPTIMIZATION_LEVEL, SPEED); @@ -3327,6 +3329,8 @@ DEFUN ("native-elisp-load", Fnative_elisp_load, Snative_elisp_load, 1, 1, 0, { CHECK_STRING (file); + Frequire (Qadvice, Qnil, Qnil); + Vnative_load_history = Fcons (file, Vnative_load_history); dynlib_handle_ptr handle = dynlib_open (SSDATA (file)); @@ -3395,6 +3399,7 @@ syms_of_comp (void) DEFSYM (Qcomp_unit_load_failed, "comp-unit-load-failed"); /* Others. */ DEFSYM (Qfixnum, "fixnum"); + DEFSYM (Qadvice, "advice"); defsubr (&Scomp__init_ctxt); defsubr (&Scomp__release_ctxt); commit 3850be836ec7223c895901dd21f2a4e429314b94 Author: Andrea Corallo Date: Sun Nov 17 18:39:22 2019 +0100 make compilation too robust against advices diff --git a/src/comp.c b/src/comp.c index 33c39b5346..ad669a5daf 100644 --- a/src/comp.c +++ b/src/comp.c @@ -224,6 +224,20 @@ bcall0 (Lisp_Object f) Ffuncall (1, &f); } +static Lisp_Object +symbol_subr (Lisp_Object symbol) +{ + Lisp_Object subr = Fsymbol_function (symbol); + + if (SUBRP (subr)) + return subr; + + if (!NILP (CALL1I (ad-has-any-advice, symbol))) + subr = CALL1I (ad-get-orig-definition, symbol); + + return SUBRP (subr) ? subr : Qnil; +} + static gcc_jit_field * type_to_cast_field (gcc_jit_type *type) { @@ -1800,7 +1814,7 @@ emit_ctxt_code (void) FOR_EACH_TAIL (f_subr) { Lisp_Object subr_sym = XCAR (f_subr); - Lisp_Object subr = Fsymbol_function (subr_sym); + Lisp_Object subr = symbol_subr (subr_sym); /* Ignore inliners. This are not real functions to be imported. */ if (SUBRP (subr)) { @@ -3225,11 +3239,8 @@ load_comp_unit (dynlib_handle_ptr handle, char *file_name) Lisp_Object subr = Fsymbol_function (f_sym); if (!NILP (subr)) { - if (!SUBRP (subr) - /* If is not a subr try to recover the original one assuming was - advised. */ - && !(!NILP (CALL1I (ad-has-any-advice, f_sym)) - && SUBRP (subr = CALL1I (ad-get-orig-definition, f_sym)))) + subr = symbol_subr (f_sym); + if (NILP (subr)) { /* FIXME: This is not robust in case of primitive redefinition. */ commit 065dd0b5c6a7e11e79fe5ec02b153bb53bde0e77 Author: Andrea Corallo Date: Sun Nov 17 16:38:07 2019 +0100 better error signaling while loading diff --git a/src/comp.c b/src/comp.c index 1de24eaaf9..33c39b5346 100644 --- a/src/comp.c +++ b/src/comp.c @@ -70,6 +70,8 @@ along with GNU Emacs. If not, see . */ #endif #define SETJMP_NAME STR (SETJMP) +/* Raise an internal compiler error if test. + msg is evaluated only in that case. */ #define ICE_IF(test, msg) \ do { \ if (test) \ @@ -3271,7 +3273,9 @@ load_comp_unit (dynlib_handle_ptr handle, char *file_name) return; exit_error: - error ("Native code load error while loading %s, %s", file_name, err_msg); + xsignal1 (Qcomp_unit_load_failed, + build_string (format_string ("while loading %s, %s", + file_name, err_msg))); } DEFUN ("comp--register-subr", Fcomp__register_subr, @@ -3284,7 +3288,9 @@ DEFUN ("comp--register-subr", Fcomp__register_subr, { dynlib_handle_ptr handle = xmint_pointer (XCAR (load_handle_stack)); if (!handle) - error ("comp--register-subr can only be called during native code load phase."); + xsignal1 (Qcomp_unit_load_failed, + build_string ("comp--register-subr can only be called during " + "native code load phase.")); void *func = dynlib_sym (handle, SSDATA (c_name)); eassert (func); @@ -3315,7 +3321,7 @@ DEFUN ("native-elisp-load", Fnative_elisp_load, Snative_elisp_load, 1, 1, 0, dynlib_handle_ptr handle = dynlib_open (SSDATA (file)); load_handle_stack = Fcons (make_mint_ptr (handle), load_handle_stack); if (!handle) - xsignal2 (Qcomp_unit_open_failed, file, build_string (dynlib_error ())); + xsignal2 (Qcomp_unit_load_failed, file, build_string (dynlib_error ())); load_comp_unit (handle, SSDATA (file)); @@ -3374,8 +3380,8 @@ syms_of_comp (void) DEFSYM (Qnegate, "negate"); DEFSYM (Qnumberp, "numberp"); DEFSYM (Qintegerp, "integerp"); - /* Returned values. */ - DEFSYM (Qcomp_unit_open_failed, "comp-unit-open-failed"); + /* To be signaled. */ + DEFSYM (Qcomp_unit_load_failed, "comp-unit-load-failed"); /* Others. */ DEFSYM (Qfixnum, "fixnum"); commit 207b15147366be47d58c40a6f03888243602b11e Author: Andrea Corallo Date: Sun Nov 17 16:04:25 2019 +0100 Vnative_units_loaded -> Vnative_load_history diff --git a/src/comp.c b/src/comp.c index cbf38de29a..1de24eaaf9 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3310,10 +3310,7 @@ DEFUN ("native-elisp-load", Fnative_elisp_load, Snative_elisp_load, 1, 1, 0, { CHECK_STRING (file); - if (NILP (Fhash_table_p (Vnative_units_loaded))) - Vnative_units_loaded = CALLN (Fmake_hash_table, QCtest, Qequal); - - Fputhash (file, Qt, Vnative_units_loaded); + Vnative_load_history = Fcons (file, Vnative_load_history); dynlib_handle_ptr handle = dynlib_open (SSDATA (file)); load_handle_stack = Fcons (make_mint_ptr (handle), load_handle_stack); @@ -3400,10 +3397,9 @@ syms_of_comp (void) doc: /* The compiler context. */); Vcomp_ctxt = Qnil; - DEFVAR_LISP ("native-units-loaded", Vnative_units_loaded, - doc: /* Hash table containing all the currently loaded - compilation units file names. */); - Vnative_units_loaded = Qnil; + DEFVAR_LISP ("native-load-history", Vnative_load_history, + doc: /* List with the history of the eln loaded. */); + Vnative_load_history = Qnil; /* Load mechanism. */ staticpro (&Vnative_elisp_refs_hash); commit 6a546e63d0134861b208ab1bac259f71fcb30b83 Author: Andrea Corallo Date: Sun Nov 17 14:17:59 2019 +0100 remove old eln before creating a new one to prevent crashes diff --git a/src/comp.c b/src/comp.c index e5d703f769..cbf38de29a 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3078,8 +3078,14 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, gcc_jit_context_dump_reproducer_to_file (comp.ctxt, "comp_reproducer.c"); AUTO_STRING (dot_so, NATIVE_ELISP_SUFFIX); + Lisp_Object out_file = CALLN (Fconcat, ctxtname, dot_so); + /* Remove the old eln before creating the new one to get a new inode and + prevent crashes in case the old one is currently loaded. */ + if (!NILP (Ffile_exists_p (out_file))) + Fdelete_file (out_file, Qnil); + gcc_jit_context_compile_to_file (comp.ctxt, GCC_JIT_OUTPUT_KIND_DYNAMIC_LIBRARY, SSDATA (out_file)); commit f6b58e8016c7ce7b332a3b2a8a56bd2f9987d95a Author: Andrea Corallo Date: Sun Nov 17 14:03:10 2019 +0100 message when finished compiling diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index e279713523..859e0dedd9 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1797,7 +1797,8 @@ Prepare every function for final compilation and drive the C back-end." "--eval" (prin1-to-string code)))) (while (accept-process-output prc) - (thread-yield))))))) + (thread-yield))))) + (message "Finished compiling."))) "compilation thread")) ;;; Compiler entry points. commit ab3f36fac2da2979713109561f086d95bb26d580 Author: Andrea Corallo Date: Sun Nov 17 12:46:21 2019 +0100 style nit into load_comp_unit diff --git a/src/comp.c b/src/comp.c index 2638290859..e5d703f769 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3217,20 +3217,18 @@ load_comp_unit (dynlib_handle_ptr handle, char *file_name) Lisp_Object subr = Fsymbol_function (f_sym); if (!NILP (subr)) { - if (!SUBRP (subr)) - { + if (!SUBRP (subr) /* If is not a subr try to recover the original one assuming was advised. */ - if (!(!NILP (CALL1I (ad-has-any-advice, f_sym)) - && SUBRP (subr = CALL1I (ad-get-orig-definition, f_sym)))) - { - /* FIXME: This is not robust in case of primitive - redefinition. */ - err_msg = format_string ("primitive %s redefined " - "or wrong relocation?", - f_str); - goto exit_error; - } + && !(!NILP (CALL1I (ad-has-any-advice, f_sym)) + && SUBRP (subr = CALL1I (ad-get-orig-definition, f_sym)))) + { + /* FIXME: This is not robust in case of primitive + redefinition. */ + err_msg = format_string ("primitive %s redefined " + "or wrong relocation?", + f_str); + goto exit_error; } f_relocs[i] = XSUBR (subr)->function.a0; } commit 437c75cfcda4a0e9fd387d22aa8c0177c835c66b Author: Andrea Corallo Date: Sun Nov 17 12:01:59 2019 +0100 add native-units-loaded diff --git a/src/comp.c b/src/comp.c index 066440bcf8..2638290859 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3305,6 +3305,12 @@ DEFUN ("native-elisp-load", Fnative_elisp_load, Snative_elisp_load, 1, 1, 0, (Lisp_Object file) { CHECK_STRING (file); + + if (NILP (Fhash_table_p (Vnative_units_loaded))) + Vnative_units_loaded = CALLN (Fmake_hash_table, QCtest, Qequal); + + Fputhash (file, Qt, Vnative_units_loaded); + dynlib_handle_ptr handle = dynlib_open (SSDATA (file)); load_handle_stack = Fcons (make_mint_ptr (handle), load_handle_stack); if (!handle) @@ -3387,10 +3393,14 @@ syms_of_comp (void) comp.emitter_dispatcher = Qnil; DEFVAR_LISP ("comp-ctxt", Vcomp_ctxt, - doc: /* - The compiler context. */); + doc: /* The compiler context. */); Vcomp_ctxt = Qnil; + DEFVAR_LISP ("native-units-loaded", Vnative_units_loaded, + doc: /* Hash table containing all the currently loaded + compilation units file names. */); + Vnative_units_loaded = Qnil; + /* Load mechanism. */ staticpro (&Vnative_elisp_refs_hash); Vnative_elisp_refs_hash commit 13f3b52fa422bed85fd7d50b43a167bb011e9070 Author: Andrea Corallo Date: Sun Nov 17 11:48:30 2019 +0100 always name the compilation unit responsible for the error diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 4012510302..e279713523 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1819,10 +1819,12 @@ Return the compilation unit filename." (symbol-name input) (file-name-sans-extension (expand-file-name input)))))) (comp-log "\n \n" 1) - (mapc (lambda (pass) - (comp-log (format "Running pass %s:\n" pass) 2) - (setq data (funcall pass data))) - comp-passes) + (condition-case err + (mapc (lambda (pass) + (comp-log (format "Running pass %s:\n" pass) 2) + (setq data (funcall pass data))) + comp-passes) + (error (error "While compiling %s: %s" input (error-message-string err)))) data)) ;;;###autoload commit f7c52087b2a836ab8913b7718ad37230a2895ef3 Author: Andrea Corallo Date: Sun Nov 17 11:20:29 2019 +0100 do not force compiler settings within the testsuite diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 34d00896b4..2a4c849a7c 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -29,9 +29,6 @@ (require 'cl-lib) (require 'comp) -(setq comp-speed 3) -(setq comp-debug 1) - (defconst comp-test-directory (file-name-directory (or load-file-name buffer-file-name))) (defconst comp-test-src commit 3d0a3a51b8f1635ec872fc3f0a54c2d58ba48b4e Author: Andrea Corallo Date: Sun Nov 17 11:19:17 2019 +0100 fix configure.ac diff --git a/configure.ac b/configure.ac index c1e3977330..03570bd6c9 100644 --- a/configure.ac +++ b/configure.ac @@ -3753,6 +3753,11 @@ if test "${with_nativecomp}" != "no"; then AC_DEFINE(HAVE_NATIVE_COMP, 1, [Define to 1 if you have the libgccjit library (-lgccjit).]) AC_DEFINE_UNQUOTED(NATIVE_ELISP_SUFFIX, ".eln", [System extension for native compiled elisp]) + else + AC_MSG_ERROR([elisp native compiler requested but libgccjit not found. +If you are sure you want Emacs compiled without elisp native compiler, pass + --without-nativecomp +to configure.]) fi fi AC_SUBST(LIBGCCJIT_LIB) @@ -5737,7 +5742,7 @@ AS_ECHO([" Does Emacs use -lXaw3d? ${HAVE_XAW3D Does Emacs support the portable dumper? ${with_pdumper} Does Emacs support legacy unexec dumping? ${with_unexec} Which dumping strategy does Emacs use? ${with_dumping} - Does Emacs have native lisp compiler? ${with_nativecomp} + Does Emacs have native lisp compiler? ${HAVE_NATIVE_COMP} "]) if test -n "${EMACSDATA}"; then commit 76fcc2a69a96a7ab68b82ebc96c234dd58ef7e61 Author: Andrea Corallo Date: Sat Nov 16 15:25:01 2019 +0100 emit_limple_push_handler style fix diff --git a/src/comp.c b/src/comp.c index d05d17bd01..066440bcf8 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1156,11 +1156,11 @@ emit_limple_push_handler (gcc_jit_rvalue *handler, gcc_jit_rvalue *handler_type, gcc_jit_rvalue *args[] = { handler, handler_type }; gcc_jit_block_add_assignment ( - comp.block, - NULL, - comp.loc_handler, - emit_call (intern_c_string ("push_handler"), - comp.handler_ptr_type, 2, args, false)); + comp.block, + NULL, + comp.loc_handler, + emit_call (intern_c_string ("push_handler"), + comp.handler_ptr_type, 2, args, false)); args[0] = gcc_jit_lvalue_get_address ( commit a82f1929fef5072a4b04e326b467cca8a8a21c0e Author: Andrea Corallo Date: Sat Nov 16 15:24:35 2019 +0100 rework comp-callref lambda list diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index d62b4cbbe1..4012510302 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -566,12 +566,13 @@ The basic block is returned regardless it was already declared or not." (comp-add-subr-to-relocs func) `(call ,func ,@args)) -(defun comp-callref (func &rest args) - "Emit a call usign narg abi for FUNC with ARGS." +(defun comp-callref (func nargs stack-off) + "Emit a call usign narg abi for FUNC. +NARGS is the number of arguments. +STACK-OFF is the index of the first slot frame involved." (comp-add-subr-to-relocs func) - `(callref ,func ,@(cl-loop with (nargs off) = args - repeat nargs - for sp from off + `(callref ,func ,@(cl-loop repeat nargs + for sp from stack-off collect (comp-slot-n sp)))) (cl-defun make-comp-mvar (&key slot (constant nil const-vld) type) commit 4bb671f1c6adb6cbdcf90abe73967c24e5296372 Author: Andrea Corallo Date: Sat Nov 16 15:23:28 2019 +0100 fix emit_limple_call_ref for 0 args case diff --git a/src/comp.c b/src/comp.c index 9f1317ef70..d05d17bd01 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1139,7 +1139,9 @@ emit_limple_call_ref (Lisp_Object insn, bool direct) Lisp_Object callee = FIRST (insn); EMACS_INT nargs = XFIXNUM (Flength (CDR (insn))); - EMACS_INT base_ptr = XFIXNUM (CALL1I (comp-mvar-slot, SECOND (insn))); + EMACS_INT base_ptr = 0; + if (nargs) + base_ptr = XFIXNUM (CALL1I (comp-mvar-slot, SECOND (insn))); return emit_call_ref (callee, nargs, comp.frame[base_ptr], direct); } commit 11b34169f802908348e99d0a52b9c50a64028964 Author: Andrea Corallo Date: Sat Nov 16 15:12:37 2019 +0100 add comp-tests-trampoline-removal diff --git a/test/src/comp-test-funcs.el b/test/src/comp-test-funcs.el index 5f33eacdb2..214e07e6dd 100644 --- a/test/src/comp-test-funcs.el +++ b/test/src/comp-test-funcs.el @@ -241,6 +241,9 @@ (defun comp-tests-string-trim-f (url) (string-trim url)) +(defun comp-tests-trampoline-removal-f () + (make-hash-table)) + ;;;;;;;;;;;;;;;;;;;; ;; Tromey's tests ;; ;;;;;;;;;;;;;;;;;;;; diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 1f43a91d49..34d00896b4 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -306,6 +306,11 @@ Check that the resulting binaries do not differ." (ert-deftest comp-tests-string-trim () (should (string= (comp-tests-string-trim-f "dsaf ") "dsaf"))) +(ert-deftest comp-tests-trampoline-removal () + ;; This tests that we can can call primitives with no dedicated bytecode. + ;; At speed >= 2 the trampoline will not be used. + (should (hash-table-p (comp-tests-trampoline-removal-f)))) + ;;;;;;;;;;;;;;;;;;;; ;; Tromey's tests ;; ;;;;;;;;;;;;;;;;;;;; commit b91cbf80aeb4487ad3e1fa0e64e3cb5549ec663c Author: Andrea Corallo Date: Sat Nov 16 09:58:05 2019 +0100 add comp-tests-bootstrap diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 2e388b9f14..1f43a91d49 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -32,13 +32,37 @@ (setq comp-speed 3) (setq comp-debug 1) +(defconst comp-test-directory (file-name-directory (or load-file-name + buffer-file-name))) (defconst comp-test-src - (concat (file-name-directory (or load-file-name buffer-file-name)) - "comp-test-funcs.el")) + (concat comp-test-directory "comp-test-funcs.el")) (message "Compiling %s" comp-test-src) (load (native-compile comp-test-src)) +(ert-deftest comp-tests-bootstrap () + "Compile the compiler and load it to compile it-self. +Check that the resulting binaries do not differ." + (let ((comp-file (concat comp-test-directory + "../../lisp/emacs-lisp/comp.el")) + (comp1-file (concat temporary-file-directory + (make-temp-name "stage1-") + ".el")) + (comp2-file (concat temporary-file-directory + (make-temp-name "stage2-") + ".el"))) + (copy-file comp-file comp1-file) + (copy-file comp-file comp2-file) + (load (concat comp-file "c") nil nil t t) + (should (null (subr-native-elisp-p (symbol-function #'native-compile)))) + (message "Compiling stage1...") + (load (native-compile comp1-file) nil nil t t) + (should (subr-native-elisp-p (symbol-function 'native-compile))) + (message "Compiling stage2...") + (native-compile comp2-file) + (message "Comparing %s %s" comp1-file comp2-file) + (should (= (call-process "cmp" nil nil nil comp1-file comp2-file) 0)))) + (ert-deftest comp-tests-provide () "Testing top level provide." (should (featurep 'comp-test-funcs))) commit 787444c7690d97d8702db059cb51ac506cb8a5e4 Author: Andrea Corallo Date: Thu Nov 14 18:01:00 2019 +0100 fix max depth compilation diff --git a/src/eval.c b/src/eval.c index 4559a0e1f6..bf37ed9cef 100644 --- a/src/eval.c +++ b/src/eval.c @@ -219,8 +219,14 @@ void init_eval_once (void) { /* Don't forget to update docs (lispref node "Local Variables"). */ +#ifndef HAVE_NATIVE_COMP max_specpdl_size = 1600; /* 1500 is not enough for cl-generic.el. */ max_lisp_eval_depth = 800; +#else + /* Original values increased for comp.el. */ + max_specpdl_size = 2100; + max_lisp_eval_depth = 1400; +#endif Vrun_hooks = Qnil; pdumper_do_now_and_after_load (init_eval_once_for_pdumper); } commit a1fd3d6eacaf425eadd121dcacee95a26f96505f Author: Andrea Corallo Date: Thu Nov 14 21:36:30 2019 +0100 improve subr-native-elisp-p diff --git a/src/data.c b/src/data.c index 2a32d47c49..50dce9e464 100644 --- a/src/data.c +++ b/src/data.c @@ -866,12 +866,11 @@ SUBR must be a built-in function. */) #ifdef HAVE_NATIVE_COMP DEFUN ("subr-native-elisp-p", Fsubr_native_elisp_p, Ssubr_native_elisp_p, 1, 1, 0, - doc: /* Return t if the subr is native compiled elisp, + doc: /* Return t if the object is native compiled lisp function, nil otherwise. */) - (Lisp_Object subr) + (Lisp_Object object) { - CHECK_SUBR (subr); - return XSUBR (subr)->native_elisp ? Qt : Qnil; + return (SUBRP (object) && XSUBR (object)->native_elisp) ? Qt : Qnil; } #endif commit 0f526028b1830e72df1c39220c5efdc7e545885b Author: Andrea Corallo Date: Wed Nov 13 21:25:00 2019 +0100 do not compile if there's nothing to diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 8ee35b0311..d62b4cbbe1 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -433,6 +433,8 @@ Put PREFIX in front of it." (defun comp-spill-lap-functions-file (filename) "Byte compile FILENAME spilling data from the byte compiler." (byte-compile-file filename) + (unless byte-to-native-top-level-forms + (error "Empty byte compiler output")) (setf (comp-ctxt-top-level-forms comp-ctxt) (reverse byte-to-native-top-level-forms)) (cl-loop for f in (cl-loop for x in byte-to-native-top-level-forms ; All non anonymous. @@ -1767,10 +1769,9 @@ Prepare every function for final compilation and drive the C back-end." (defun comp-to-file-p (file) "Return t if FILE has to be compiled." (let ((compiled-f (concat file "n"))) - (and (null (string-match-p "autoloads.el" file)) - (or comp-always-compile - (not (and (file-exists-p compiled-f) - (file-newer-than-file-p compiled-f file))))))) + (or comp-always-compile + (not (and (file-exists-p compiled-f) + (file-newer-than-file-p compiled-f file)))))) (defun comp-start-async-worker () "Start an async compiler worker." commit 9b44051ea530247e73dbc0bdc2998d2dbf9688c1 Author: Andrea Corallo Date: Wed Nov 13 21:12:29 2019 +0100 make load mechanism robust against primitives advises diff --git a/src/comp.c b/src/comp.c index 3ffb0db62a..9f1317ef70 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3215,53 +3215,49 @@ load_comp_unit (dynlib_handle_ptr handle, char *file_name) Lisp_Object subr = Fsymbol_function (f_sym); if (!NILP (subr)) { - /* FIXME: This is really not robust in case of subr redefinition. */ if (!SUBRP (subr)) { - err_msg = format_string ("subr %s redefined or wrong relocation?", f_str); - goto exit_error; + /* If is not a subr try to recover the original one assuming was + advised. */ + if (!(!NILP (CALL1I (ad-has-any-advice, f_sym)) + && SUBRP (subr = CALL1I (ad-get-orig-definition, f_sym)))) + { + /* FIXME: This is not robust in case of primitive + redefinition. */ + err_msg = format_string ("primitive %s redefined " + "or wrong relocation?", + f_str); + goto exit_error; + } } f_relocs[i] = XSUBR (subr)->function.a0; - } else if (!strcmp (f_str, "wrong_type_argument")) - { - f_relocs[i] = (void *) wrong_type_argument; - } else if (!strcmp (f_str, "helper_PSEUDOVECTOR_TYPEP_XUNTAG")) - { - f_relocs[i] = (void *) helper_PSEUDOVECTOR_TYPEP_XUNTAG; - } else if (!strcmp (f_str, "pure_write_error")) - { - f_relocs[i] = (void *) pure_write_error; - } else if (!strcmp (f_str, "push_handler")) - { - f_relocs[i] = (void *) push_handler; - } else if (!strcmp (f_str, SETJMP_NAME)) - { - f_relocs[i] = (void *) SETJMP; - } else if (!strcmp (f_str, "record_unwind_protect_excursion")) - { - f_relocs[i] = (void *) record_unwind_protect_excursion; - } else if (!strcmp (f_str, "helper_unbind_n")) - { - f_relocs[i] = (void *) helper_unbind_n; - } else if (!strcmp (f_str, "helper_save_restriction")) - { - f_relocs[i] = (void *) helper_save_restriction; - } else if (!strcmp (f_str, "record_unwind_current_buffer")) - { - f_relocs[i] = (void *) record_unwind_current_buffer; - } else if (!strcmp (f_str, "set_internal")) - { - f_relocs[i] = (void *) set_internal; - } else if (!strcmp (f_str, "helper_unwind_protect")) - { - f_relocs[i] = (void *) helper_unwind_protect; - } else if (!strcmp (f_str, "specbind")) - { - f_relocs[i] = (void *) specbind; - } else - { - err_msg = format_string ("unexpected function relocation %s.", f_str); } + else if (!strcmp (f_str, "wrong_type_argument")) + f_relocs[i] = (void *) wrong_type_argument; + else if (!strcmp (f_str, "helper_PSEUDOVECTOR_TYPEP_XUNTAG")) + f_relocs[i] = (void *) helper_PSEUDOVECTOR_TYPEP_XUNTAG; + else if (!strcmp (f_str, "pure_write_error")) + f_relocs[i] = (void *) pure_write_error; + else if (!strcmp (f_str, "push_handler")) + f_relocs[i] = (void *) push_handler; + else if (!strcmp (f_str, SETJMP_NAME)) + f_relocs[i] = (void *) SETJMP; + else if (!strcmp (f_str, "record_unwind_protect_excursion")) + f_relocs[i] = (void *) record_unwind_protect_excursion; + else if (!strcmp (f_str, "helper_unbind_n")) + f_relocs[i] = (void *) helper_unbind_n; + else if (!strcmp (f_str, "helper_save_restriction")) + f_relocs[i] = (void *) helper_save_restriction; + else if (!strcmp (f_str, "record_unwind_current_buffer")) + f_relocs[i] = (void *) record_unwind_current_buffer; + else if (!strcmp (f_str, "set_internal")) + f_relocs[i] = (void *) set_internal; + else if (!strcmp (f_str, "helper_unwind_protect")) + f_relocs[i] = (void *) helper_unwind_protect; + else if (!strcmp (f_str, "specbind")) + f_relocs[i] = (void *) specbind; + else + err_msg = format_string ("unexpected function relocation %s.", f_str); } /* Executing this will perform all the expected environment modification. */ commit 6317f9e7b847f83e6a6d0f9ce9233a0566d84f0c Author: Andrea Corallo Date: Wed Nov 13 22:00:38 2019 +0100 better error handling into load_comp_unit diff --git a/src/comp.c b/src/comp.c index 04cee63dfb..3ffb0db62a 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3170,9 +3170,10 @@ load_static_obj (dynlib_handle_ptr handle, const char *name) return Fread (make_string (res->data, res->len)); } -static int -load_comp_unit (dynlib_handle_ptr handle) +static void +load_comp_unit (dynlib_handle_ptr handle, char *file_name) { + const char *err_msg; struct thread_state ***current_thread_reloc = dynlib_sym (handle, CURRENT_THREAD_RELOC_SYM); EMACS_INT ***pure_reloc = dynlib_sym (handle, PURE_RELOC_SYM); @@ -3185,7 +3186,10 @@ load_comp_unit (dynlib_handle_ptr handle) && data_relocs && f_relocs && top_level_run)) - return -1; + { + err_msg = "inconsistent eln file."; + goto exit_error; + } *current_thread_reloc = ¤t_thread; *pure_reloc = (EMACS_INT **)&pure; @@ -3213,7 +3217,10 @@ load_comp_unit (dynlib_handle_ptr handle) { /* FIXME: This is really not robust in case of subr redefinition. */ if (!SUBRP (subr)) - error ("Native code load error, subr redefined or wrong relocation."); + { + err_msg = format_string ("subr %s redefined or wrong relocation?", f_str); + goto exit_error; + } f_relocs[i] = XSUBR (subr)->function.a0; } else if (!strcmp (f_str, "wrong_type_argument")) { @@ -3253,14 +3260,16 @@ load_comp_unit (dynlib_handle_ptr handle) f_relocs[i] = (void *) specbind; } else { - ice (format_string ("unexpected function relocation %s", f_str)); + err_msg = format_string ("unexpected function relocation %s.", f_str); } } /* Executing this will perform all the expected environment modification. */ top_level_run (); - return 0; + return; +exit_error: + error ("Native code load error while loading %s, %s", file_name, err_msg); } DEFUN ("comp--register-subr", Fcomp__register_subr, @@ -3303,9 +3312,7 @@ DEFUN ("native-elisp-load", Fnative_elisp_load, Snative_elisp_load, 1, 1, 0, if (!handle) xsignal2 (Qcomp_unit_open_failed, file, build_string (dynlib_error ())); - int r = load_comp_unit (handle); - if (r != 0) - xsignal2 (Qcomp_unit_init_failed, file, INT_TO_INTEGER (r)); + load_comp_unit (handle, SSDATA (file)); load_handle_stack = XCDR (load_handle_stack); @@ -3364,7 +3371,6 @@ syms_of_comp (void) DEFSYM (Qintegerp, "integerp"); /* Returned values. */ DEFSYM (Qcomp_unit_open_failed, "comp-unit-open-failed"); - DEFSYM (Qcomp_unit_init_failed, "comp-unit-init-failed"); /* Others. */ DEFSYM (Qfixnum, "fixnum"); commit 0f59ce58fc558643f97175a32f2a82cc209f2bb4 Author: Andrea Corallo Date: Tue Nov 12 23:39:24 2019 +0100 temporary fix subr doc field to zero diff --git a/src/comp.c b/src/comp.c index f92bc62506..04cee63dfb 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3285,6 +3285,7 @@ DEFUN ("comp--register-subr", Fcomp__register_subr, x->s.max_args = FIXNUMP (maxarg) ? XFIXNUM (maxarg) : MANY; x->s.symbol_name = SSDATA (Fsymbol_name (name)); x->s.intspec = NULL; + x->s.doc = 0; /* FIXME */ x->s.native_elisp = true; defsubr (x); commit 06fc663f519eefb431912ebdae8711ed016e0703 Author: Andrea Corallo Date: Tue Nov 12 23:27:09 2019 +0100 better configure check for libgccjit.h file instead of the shared lib in configure diff --git a/configure.ac b/configure.ac index c86dac6a65..c1e3977330 100644 --- a/configure.ac +++ b/configure.ac @@ -3742,7 +3742,7 @@ HAVE_NATIVE_COMP=no LIBGCCJIT_LIB= COMP_OBJ= if test "${with_nativecomp}" != "no"; then - AC_CHECK_LIB(gccjit, gcc_jit_context_acquire, HAVE_NATIVE_COMP=yes, , -lgccjit) + AC_CHECK_HEADER([libgccjit.h], [HAVE_NATIVE_COMP=yes]) if test "${HAVE_NATIVE_COMP}" = "yes"; then LIBGCCJIT_LIB="-lgccjit -ldl" if test "${HAVE_MODULES}" = yes; then commit f59a96f5655c0ac2846a06cbad11ef3039476fb0 Author: Andrea Corallo Date: Tue Nov 12 23:00:02 2019 +0100 fix compilation when native compiler is not enabled diff --git a/src/pdumper.c b/src/pdumper.c index 7b3109607b..38b70146b4 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -2937,7 +2937,9 @@ dump_subr (struct dump_context *ctx, const struct Lisp_Subr *subr) dump_field_emacs_ptr (ctx, &out, subr, &subr->symbol_name); dump_field_emacs_ptr (ctx, &out, subr, &subr->intspec); DUMP_FIELD_COPY (&out, subr, doc); +#ifdef HAVE_NATIVE_COMP DUMP_FIELD_COPY (&out, subr, native_elisp); +#endif return dump_object_finish (ctx, &out, sizeof (out)); } commit d8f3f8736c7d36b220a478f98deae9f82f25a4f7 Author: Andrea Corallo Date: Tue Nov 12 23:44:02 2019 +0100 do not compile automatically autoloads diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 1acb97d1e0..8ee35b0311 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1767,9 +1767,10 @@ Prepare every function for final compilation and drive the C back-end." (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)))))) + (and (null (string-match-p "autoloads.el" file)) + (or comp-always-compile + (not (and (file-exists-p compiled-f) + (file-newer-than-file-p compiled-f file))))))) (defun comp-start-async-worker () "Start an async compiler worker." commit 8b8b8539d7415f1decde46d088c89c2fc69b1010 Author: Andrea Corallo Date: Tue Nov 12 19:56:35 2019 +0100 cleanup unnecessary symbol definition diff --git a/src/comp.c b/src/comp.c index 3cb0fb285b..f92bc62506 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3325,7 +3325,6 @@ syms_of_comp (void) DEFSYM (Qcallref, "callref"); DEFSYM (Qdirect_call, "direct-call"); DEFSYM (Qdirect_callref, "direct-callref"); - DEFSYM (Qncall, "ncall"); DEFSYM (Qsetimm, "setimm"); DEFSYM (Qreturn, "return"); DEFSYM (Qcomp_mvar, "comp-mvar"); commit 4320307843b44fa049ba7e8217f0349932ff56e5 Author: Andrea Corallo Date: Tue Nov 12 19:55:57 2019 +0100 propagate load-path into async workers + better messaging diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index eab8ffc216..1acb97d1e0 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1779,18 +1779,23 @@ Prepare every function for final compilation and drive the C back-end." (while (setf f (with-mutex comp-src-pool-mutex (pop comp-src-pool))) (when (comp-to-file-p f) - (let* ((code `(let ((comp-speed ,comp-speed) - (comp-debug ,comp-debug) - (comp-verbose ,comp-verbose)) + (let* ((code `(progn + (require 'comp) + (setq comp-speed ,comp-speed) + (setq comp-debug ,comp-debug) + (setq comp-verbose ,comp-verbose) + (setq load-path ',load-path) + (message "Compiling %s started." ,f) (native-compile ,f))) - (cmd (concat invocation-directory invocation-name - " --batch --eval='" - (prin1-to-string code) "'")) - (prc (start-process-shell-command (concat "async compilation: " f) - "async-compile-buffer" - cmd))) + (prc (start-process (concat "Compiling: " f) + "async-compile-buffer" + (concat invocation-directory invocation-name) + "--batch" + "--eval" + (prin1-to-string code)))) (while (accept-process-output prc) - (thread-yield))))))))) + (thread-yield))))))) + "compilation thread")) ;;; Compiler entry points. commit 0cf4a9fdfc63577c97ff0d0e46f49cd685c5291f Author: Andrea Corallo Date: Mon Nov 11 22:16:38 2019 +0100 set intspec to NULL when creating subrs diff --git a/src/comp.c b/src/comp.c index ffe0ee81e1..3cb0fb285b 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3284,6 +3284,7 @@ DEFUN ("comp--register-subr", Fcomp__register_subr, x->s.min_args = XFIXNUM (minarg); x->s.max_args = FIXNUMP (maxarg) ? XFIXNUM (maxarg) : MANY; x->s.symbol_name = SSDATA (Fsymbol_name (name)); + x->s.intspec = NULL; x->s.native_elisp = true; defsubr (x); commit fd42b6c696564cdb44999f6d4d3f91a63799191a Author: Andrea Corallo Date: Mon Nov 11 21:03:48 2019 +0100 make sure to invoke the right emacs when spawning the compiler job diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index bf373e0b02..eab8ffc216 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -51,6 +51,7 @@ (defcustom comp-debug 0 "Compiler debug level. From 0 to 3. - 0 no debug facility. + This is the raccomanded value unless you are debugging the compiler itself. - 1 emit debug symbols and dump pseudo C code. - 2 dump gcc passes and libgccjit log file. - 3 dump libgccjit reproducers." @@ -1288,7 +1289,7 @@ Top level forms for the current context are rendered too." initially (setf changed nil) do (cl-loop for p in (delq new-idom preds) when (comp-block-dom p) - do (setf new-idom (intersect p new-idom))) + do (setf new-idom (intersect p new-idom))) unless (eq (comp-block-dom b) new-idom) do (setf (comp-block-dom b) new-idom) (setf changed t)))))) @@ -1782,7 +1783,8 @@ Prepare every function for final compilation and drive the C back-end." (comp-debug ,comp-debug) (comp-verbose ,comp-verbose)) (native-compile ,f))) - (cmd (concat "emacs --batch --eval='" + (cmd (concat invocation-directory invocation-name + " --batch --eval='" (prin1-to-string code) "'")) (prc (start-process-shell-command (concat "async compilation: " f) "async-compile-buffer" commit 009089f0d69a26e9779628e5b9c1d139eddf20d2 Author: Andrea Corallo Date: Mon Nov 11 17:46:34 2019 +0100 chasing GNU style diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 99243fda2c..bf373e0b02 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1428,7 +1428,7 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non nil." for e in (comp-block-in-edges b) for b = (comp-edge-src e) for in-frame = (comp-block-final-frame b) - collect (aref in-frame slot-n))) )) + collect (aref in-frame slot-n))))) (cl-loop for b being each hash-value of (comp-func-blocks comp-func) do (cl-loop for (op . args) in (comp-block-insns b) diff --git a/src/comp.c b/src/comp.c index 6b00e1a429..ffe0ee81e1 100644 --- a/src/comp.c +++ b/src/comp.c @@ -57,11 +57,11 @@ along with GNU Emacs. If not, see . */ /* Like call1 but stringify and intern. */ #define CALL1I(fun, arg) \ - CALLN (Ffuncall, intern_c_string (STR(fun)), arg) + CALLN (Ffuncall, intern_c_string (STR (fun)), arg) #define DECL_BLOCK(name, func) \ gcc_jit_block *(name) = \ - gcc_jit_function_new_block ((func), STR(name)) + gcc_jit_function_new_block ((func), STR (name)) #ifdef HAVE__SETJMP #define SETJMP _setjmp @@ -72,11 +72,11 @@ along with GNU Emacs. If not, see . */ #define ICE_IF(test, msg) \ do { \ - if (test) \ - ice (msg); \ + if (test) \ + ice (msg); \ } while (0) -/* C side of the compiler context. */ +/* C side of the compiler context. */ typedef struct { gcc_jit_context *ctxt; @@ -340,10 +340,10 @@ declare_imported_func (Lisp_Object subr_sym, gcc_jit_type *ret_type, types[i] = comp.lisp_obj_type; } - /* String containing the function ptr name. */ + /* String containing the function ptr name. */ Lisp_Object f_ptr_name = CALLN (Ffuncall, intern_c_string (STR (comp-c-func-name)), - subr_sym, make_string("R", 1)); + subr_sym, make_string ("R", 1)); gcc_jit_type *f_ptr_type = gcc_jit_context_new_function_ptr_type (comp.ctxt, @@ -381,7 +381,8 @@ emit_call (Lisp_Object subr_sym, gcc_jit_type *ret_type, unsigned nargs, xmint_pointer (func), nargs, args); - } else { + } + else { gcc_jit_lvalue *f_ptr = gcc_jit_lvalue_access_field (comp.func_relocs, NULL, @@ -402,9 +403,9 @@ emit_call_ref (Lisp_Object subr_sym, unsigned nargs, gcc_jit_lvalue *base_arg, bool direct) { gcc_jit_rvalue *args[] = - { gcc_jit_context_new_rvalue_from_int(comp.ctxt, - comp.ptrdiff_type, - nargs), + { gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.ptrdiff_type, + nargs), gcc_jit_lvalue_get_address (base_arg, NULL) }; return emit_call (subr_sym, comp.lisp_obj_type, 2, args, direct); } @@ -757,7 +758,7 @@ emit_NUMBERP (gcc_jit_rvalue *obj) NULL, GCC_JIT_BINARY_OP_LOGICAL_OR, comp.bool_type, - emit_INTEGERP(obj), + emit_INTEGERP (obj), emit_cast (comp.bool_type, emit_FLOATP (obj))); } @@ -962,7 +963,7 @@ emit_XSETCAR (gcc_jit_rvalue *c, gcc_jit_rvalue *n) { emit_comment ("XSETCAR"); - gcc_jit_block_add_assignment( + gcc_jit_block_add_assignment ( comp.block, NULL, gcc_jit_rvalue_dereference ( @@ -976,7 +977,7 @@ emit_XSETCDR (gcc_jit_rvalue *c, gcc_jit_rvalue *n) { emit_comment ("XSETCDR"); - gcc_jit_block_add_assignment( + gcc_jit_block_add_assignment ( comp.block, NULL, gcc_jit_rvalue_dereference ( @@ -1033,9 +1034,9 @@ emit_mvar_val (Lisp_Object mvar) (read fixnums). */ emit_comment (SSDATA (Fprin1_to_string (constant, Qnil))); gcc_jit_rvalue *word = - gcc_jit_context_new_rvalue_from_ptr(comp.ctxt, - comp.void_ptr_type, - constant); + gcc_jit_context_new_rvalue_from_ptr (comp.ctxt, + comp.void_ptr_type, + constant); return emit_cast (comp.lisp_obj_type, word); } /* Other const objects are fetched from the reloc array. */ @@ -1079,7 +1080,7 @@ emit_set_internal (Lisp_Object args) gcc_args, false); } -/* This is for a regular function with arguments as m-var. */ +/* This is for a regular function with arguments as m-var. */ static gcc_jit_rvalue * emit_simple_limple_call (Lisp_Object args, gcc_jit_type *ret_type, bool direct) @@ -1192,7 +1193,7 @@ emit_limple_insn (Lisp_Object insn) if (EQ (op, Qjump)) { - /* Unconditional branch. */ + /* Unconditional branch. */ gcc_jit_block *target = retrive_block (arg[0]); gcc_jit_block_end_with_jump (comp.block, NULL, target); } @@ -1230,7 +1231,7 @@ emit_limple_insn (Lisp_Object insn) } else if (EQ (op, Qphi)) { - /* Nothing to do for phis into the backend. */ + /* Nothing to do for phis into the backend. */ } else if (EQ (op, Qpush_handler)) { @@ -1266,7 +1267,7 @@ emit_limple_insn (Lisp_Object insn) NULL, comp.m_handlerlist); - gcc_jit_block_add_assignment( + gcc_jit_block_add_assignment ( comp.block, NULL, m_handlerlist, @@ -1294,14 +1295,14 @@ emit_limple_insn (Lisp_Object insn) comp.block, NULL, m_handlerlist, - gcc_jit_lvalue_as_rvalue( + gcc_jit_lvalue_as_rvalue ( gcc_jit_rvalue_dereference_field ( gcc_jit_lvalue_as_rvalue (comp.loc_handler), NULL, comp.handler_next_field))); emit_frame_assignment ( arg[0], - gcc_jit_lvalue_as_rvalue( + gcc_jit_lvalue_as_rvalue ( gcc_jit_rvalue_dereference_field ( gcc_jit_lvalue_as_rvalue (comp.loc_handler), NULL, @@ -1667,7 +1668,7 @@ static Lisp_Object declare_runtime_imported_funcs (void) { /* For subr imported by the runtime we rely on the standard mechanism in place - for functions imported by lisp code. */ + for functions imported by lisp code. */ CALL1I (comp-add-subr-to-relocs, intern_c_string ("1+")); CALL1I (comp-add-subr-to-relocs, intern_c_string ("1-")); CALL1I (comp-add-subr-to-relocs, Qplus); @@ -1760,7 +1761,7 @@ emit_ctxt_code (void) d_reloc = Fvconcat (1, &d_reloc); comp.data_relocs = - gcc_jit_lvalue_as_rvalue( + gcc_jit_lvalue_as_rvalue ( gcc_jit_context_new_global ( comp.ctxt, NULL, @@ -1777,7 +1778,7 @@ emit_ctxt_code (void) Lisp_Object f_runtime = declare_runtime_imported_funcs (); EMACS_INT f_reloc_len = XFIXNUM (Flength (f_runtime)); - /* Imported subrs. */ + /* Imported subrs. */ Lisp_Object f_subr = CALL1I (comp-ctxt-func-relocs-l, Vcomp_ctxt); f_reloc_len += XFIXNUM (Flength (f_subr)); @@ -1805,7 +1806,7 @@ emit_ctxt_code (void) FIXNUMP (maxarg) ? XFIXNUM (maxarg) : EQ (maxarg, Qmany) ? MANY : UNEVALLED, NULL); - fields [n_frelocs++] = field; + fields[n_frelocs++] = field; f_reloc_list = Fcons (subr_sym, f_reloc_list); } } @@ -2261,7 +2262,7 @@ define_CAR_CDR (void) gcc_jit_context_new_function (comp.ctxt, NULL, GCC_JIT_FUNCTION_INTERNAL, comp.lisp_obj_type, - f_name [i], + f_name[i], 2, param, 0); gcc_jit_rvalue *c = gcc_jit_param_as_rvalue (param[0]); @@ -2865,7 +2866,7 @@ DEFUN ("comp--init-ctxt", Fcomp__init_ctxt, Scomp__init_ctxt, if (NILP (comp.emitter_dispatcher)) { - /* Move this into syms_of_comp the day will be dumpable. */ + /* Move this into syms_of_comp the day will be dumpable. */ comp.emitter_dispatcher = CALLN (Fmake_hash_table); register_emitter (Qset_internal, emit_set_internal); register_emitter (Qhelper_unbind_n, emit_simple_limple_call_lisp_ret); @@ -2890,7 +2891,7 @@ DEFUN ("comp--init-ctxt", Fcomp__init_ctxt, Scomp__init_ctxt, register_emitter (Qintegerp, emit_integerp); } - comp.ctxt = gcc_jit_context_acquire(); + comp.ctxt = gcc_jit_context_acquire (); if (COMP_DEBUG) { @@ -3016,7 +3017,7 @@ DEFUN ("comp--release-ctxt", Fcomp__release_ctxt, Scomp__release_ctxt, (void) { if (comp.ctxt) - gcc_jit_context_release(comp.ctxt); + gcc_jit_context_release (comp.ctxt); if (logfile) fclose (logfile); @@ -3049,7 +3050,7 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, emit_ctxt_code (); /* Define inline functions. */ - define_CAR_CDR(); + define_CAR_CDR (); define_PSEUDOVECTORP (); define_CHECK_TYPE (); define_CHECK_IMPURE (); @@ -3165,7 +3166,7 @@ load_static_obj (dynlib_handle_ptr handle, const char *name) { static_obj_t *(*f)(void) = dynlib_sym (handle, name); eassert (f); - static_obj_t *res = f(); + static_obj_t *res = f (); return Fread (make_string (res->data, res->len)); } @@ -3284,12 +3285,12 @@ DEFUN ("comp--register-subr", Fcomp__register_subr, x->s.max_args = FIXNUMP (maxarg) ? XFIXNUM (maxarg) : MANY; x->s.symbol_name = SSDATA (Fsymbol_name (name)); x->s.native_elisp = true; - defsubr(x); + defsubr (x); return Qnil; } -/* Load related routines. */ +/* Load related routines. */ DEFUN ("native-elisp-load", Fnative_elisp_load, Snative_elisp_load, 1, 1, 0, doc: /* Load native elisp code FILE. */) (Lisp_Object file) @@ -3382,7 +3383,7 @@ syms_of_comp (void) DEFVAR_LISP ("comp-ctxt", Vcomp_ctxt, doc: /* - The compiler context. */); + The compiler context. */); Vcomp_ctxt = Qnil; /* Load mechanism. */ commit 7c9a3556e3d66c1ebe75f675341117bb28041da8 Author: Andrea Corallo Date: Mon Nov 11 17:32:27 2019 +0100 better FUNCALL1 name diff --git a/src/comp.c b/src/comp.c index 278bf82e6b..6b00e1a429 100644 --- a/src/comp.c +++ b/src/comp.c @@ -55,7 +55,8 @@ along with GNU Emacs. If not, see . */ #define THIRD(x) \ XCAR (XCDR (XCDR (x))) -#define FUNCALL1(fun, arg) \ +/* Like call1 but stringify and intern. */ +#define CALL1I(fun, arg) \ CALLN (Ffuncall, intern_c_string (STR(fun)), arg) #define DECL_BLOCK(name, func) \ @@ -283,9 +284,9 @@ declare_block (Lisp_Object block_name) static gcc_jit_lvalue * get_slot (Lisp_Object mvar) { - EMACS_INT slot_n = XFIXNUM (FUNCALL1 (comp-mvar-slot, mvar)); + EMACS_INT slot_n = XFIXNUM (CALL1I (comp-mvar-slot, mvar)); gcc_jit_lvalue **frame = - (FUNCALL1 (comp-mvar-ref, mvar) || SPEED < 2) + (CALL1I (comp-mvar-ref, mvar) || SPEED < 2) ? comp.frame : comp.f_frame; return frame[slot_n]; } @@ -806,7 +807,7 @@ emit_const_lisp_obj (Lisp_Object obj) comp.void_ptr_type, NULL)); - Lisp_Object d_reloc_idx = FUNCALL1 (comp-ctxt-data-relocs-idx, Vcomp_ctxt); + Lisp_Object d_reloc_idx = CALL1I (comp-ctxt-data-relocs-idx, Vcomp_ctxt); ptrdiff_t reloc_fixn = XFIXNUM (Fgethash (obj, d_reloc_idx, Qnil)); gcc_jit_rvalue *reloc_n = gcc_jit_context_new_rvalue_from_int (comp.ctxt, @@ -1021,8 +1022,8 @@ emit_PURE_P (gcc_jit_rvalue *ptr) static gcc_jit_rvalue * emit_mvar_val (Lisp_Object mvar) { - Lisp_Object const_vld = FUNCALL1 (comp-mvar-const-vld, mvar); - Lisp_Object constant = FUNCALL1 (comp-mvar-constant, mvar); + Lisp_Object const_vld = CALL1I (comp-mvar-const-vld, mvar); + Lisp_Object constant = CALL1I (comp-mvar-constant, mvar); if (!NILP (const_vld)) { @@ -1137,7 +1138,7 @@ emit_limple_call_ref (Lisp_Object insn, bool direct) Lisp_Object callee = FIRST (insn); EMACS_INT nargs = XFIXNUM (Flength (CDR (insn))); - EMACS_INT base_ptr = XFIXNUM (FUNCALL1 (comp-mvar-slot, SECOND (insn))); + EMACS_INT base_ptr = XFIXNUM (CALL1I (comp-mvar-slot, SECOND (insn))); return emit_call_ref (callee, nargs, comp.frame[base_ptr], direct); } @@ -1379,7 +1380,7 @@ emit_limple_insn (Lisp_Object insn) C: local[2] = list (nargs - 2, args); */ - EMACS_INT slot_n = XFIXNUM (FUNCALL1 (comp-mvar-slot, arg[0])); + EMACS_INT slot_n = XFIXNUM (CALL1I (comp-mvar-slot, arg[0])); gcc_jit_rvalue *n = gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.ptrdiff_type, @@ -1463,7 +1464,7 @@ static gcc_jit_rvalue * emit_call_with_type_hint (gcc_jit_function *func, Lisp_Object insn, Lisp_Object type) { - bool type_hint = EQ (FUNCALL1 (comp-mvar-type, SECOND (insn)), type); + bool type_hint = EQ (CALL1I (comp-mvar-type, SECOND (insn)), type); gcc_jit_rvalue *args[] = { emit_mvar_val (SECOND (insn)), gcc_jit_context_new_rvalue_from_int (comp.ctxt, @@ -1478,7 +1479,7 @@ static gcc_jit_rvalue * emit_call2_with_type_hint (gcc_jit_function *func, Lisp_Object insn, Lisp_Object type) { - bool type_hint = EQ (FUNCALL1 (comp-mvar-type, SECOND (insn)), type); + bool type_hint = EQ (CALL1I (comp-mvar-type, SECOND (insn)), type); gcc_jit_rvalue *args[] = { emit_mvar_val (SECOND (insn)), emit_mvar_val (THIRD (insn)), @@ -1652,10 +1653,10 @@ static void declare_runtime_imported_data (void) { /* Imported symbols by inliner functions. */ - FUNCALL1 (comp-add-const-to-relocs, Qnil); - FUNCALL1 (comp-add-const-to-relocs, Qt); - FUNCALL1 (comp-add-const-to-relocs, Qconsp); - FUNCALL1 (comp-add-const-to-relocs, Qlistp); + CALL1I (comp-add-const-to-relocs, Qnil); + CALL1I (comp-add-const-to-relocs, Qt); + CALL1I (comp-add-const-to-relocs, Qconsp); + CALL1I (comp-add-const-to-relocs, Qlistp); } /* @@ -1667,11 +1668,11 @@ declare_runtime_imported_funcs (void) { /* For subr imported by the runtime we rely on the standard mechanism in place for functions imported by lisp code. */ - FUNCALL1 (comp-add-subr-to-relocs, intern_c_string ("1+")); - FUNCALL1 (comp-add-subr-to-relocs, intern_c_string ("1-")); - FUNCALL1 (comp-add-subr-to-relocs, Qplus); - FUNCALL1 (comp-add-subr-to-relocs, Qminus); - FUNCALL1 (comp-add-subr-to-relocs, Qlist); + CALL1I (comp-add-subr-to-relocs, intern_c_string ("1+")); + CALL1I (comp-add-subr-to-relocs, intern_c_string ("1-")); + CALL1I (comp-add-subr-to-relocs, Qplus); + CALL1I (comp-add-subr-to-relocs, Qminus); + CALL1I (comp-add-subr-to-relocs, Qlist); Lisp_Object field_list = Qnil; #define ADD_IMPORTED(f_name, ret_type, nargs, args) \ @@ -1753,9 +1754,9 @@ emit_ctxt_code (void) declare_runtime_imported_data (); /* Imported objects. */ EMACS_INT d_reloc_len = - XFIXNUM (FUNCALL1 (hash-table-count, - FUNCALL1 (comp-ctxt-data-relocs-idx, Vcomp_ctxt))); - Lisp_Object d_reloc = Fnreverse (FUNCALL1 (comp-ctxt-data-relocs-l, Vcomp_ctxt)); + XFIXNUM (CALL1I (hash-table-count, + CALL1I (comp-ctxt-data-relocs-idx, Vcomp_ctxt))); + Lisp_Object d_reloc = Fnreverse (CALL1I (comp-ctxt-data-relocs-l, Vcomp_ctxt)); d_reloc = Fvconcat (1, &d_reloc); comp.data_relocs = @@ -1777,7 +1778,7 @@ emit_ctxt_code (void) EMACS_INT f_reloc_len = XFIXNUM (Flength (f_runtime)); /* Imported subrs. */ - Lisp_Object f_subr = FUNCALL1 (comp-ctxt-func-relocs-l, Vcomp_ctxt); + Lisp_Object f_subr = CALL1I (comp-ctxt-func-relocs-l, Vcomp_ctxt); f_reloc_len += XFIXNUM (Flength (f_subr)); gcc_jit_field **fields = SAFE_ALLOCA (f_reloc_len * sizeof (*fields)); @@ -2702,14 +2703,14 @@ static void declare_function (Lisp_Object func) { gcc_jit_function *gcc_func; - char *c_name = SSDATA (FUNCALL1 (comp-func-c-func-name, func)); - Lisp_Object args = FUNCALL1 (comp-func-args, func); - bool nargs = (FUNCALL1 (comp-nargs-p, args)); + char *c_name = SSDATA (CALL1I (comp-func-c-func-name, func)); + Lisp_Object args = CALL1I (comp-func-args, func); + bool nargs = (CALL1I (comp-nargs-p, args)); USE_SAFE_ALLOCA; if (!nargs) { - EMACS_INT max_args = XFIXNUM (FUNCALL1 (comp-args-max, args)); + EMACS_INT max_args = XFIXNUM (CALL1I (comp-args-max, args)); gcc_jit_type **type = SAFE_ALLOCA (max_args * sizeof (*type)); for (unsigned i = 0; i < max_args; i++) type[i] = comp.lisp_obj_type; @@ -2747,7 +2748,7 @@ declare_function (Lisp_Object func) c_name, 2, param, 0); } - Fputhash (FUNCALL1 (comp-func-symbol-name, func), + Fputhash (CALL1I (comp-func-symbol-name, func), make_mint_ptr (gcc_func), comp.exported_funcs_h); @@ -2758,9 +2759,9 @@ static void compile_function (Lisp_Object func) { USE_SAFE_ALLOCA; - EMACS_INT frame_size = XFIXNUM (FUNCALL1 (comp-func-frame-size, func)); + EMACS_INT frame_size = XFIXNUM (CALL1I (comp-func-frame-size, func)); - comp.func = xmint_pointer (Fgethash (FUNCALL1 (comp-func-symbol-name, func), + comp.func = xmint_pointer (Fgethash (CALL1I (comp-func-symbol-name, func), comp.exported_funcs_h, Qnil)); gcc_jit_lvalue *frame_array = @@ -2813,7 +2814,7 @@ compile_function (Lisp_Object func) /* Pre declare all basic blocks to gcc. The "entry" block must be declared as first. */ declare_block (Qentry); - Lisp_Object blocks = FUNCALL1 (comp-func-blocks, func); + Lisp_Object blocks = CALL1I (comp-func-blocks, func); Lisp_Object entry_block = Fgethash (Qentry, blocks, Qnil); struct Lisp_Hash_Table *ht = XHASH_TABLE (blocks); for (ptrdiff_t i = 0; i < ht->count; i++) @@ -2827,7 +2828,7 @@ compile_function (Lisp_Object func) { Lisp_Object block_name = HASH_KEY (ht, i); Lisp_Object block = HASH_VALUE (ht, i); - Lisp_Object insns = FUNCALL1 (comp-block-insns, block); + Lisp_Object insns = CALL1I (comp-block-insns, block); ICE_IF (NILP (block) || NILP (insns), "basic block is missing or empty"); comp.block = retrive_block (block_name); @@ -2841,7 +2842,7 @@ compile_function (Lisp_Object func) const char *err = gcc_jit_context_get_first_error (comp.ctxt); ICE_IF (err, format_string ("failing to compile function %s with error: %s", - SSDATA (SYMBOL_NAME (FUNCALL1 (comp-func-symbol-name, func))), + SSDATA (SYMBOL_NAME (CALL1I (comp-func-symbol-name, func))), err)); SAFE_FREE (); } @@ -3058,7 +3059,7 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, define_negate (); struct Lisp_Hash_Table *func_h - = XHASH_TABLE (FUNCALL1 (comp-ctxt-funcs-h, Vcomp_ctxt)); + = XHASH_TABLE (CALL1I (comp-ctxt-funcs-h, Vcomp_ctxt)); for (ptrdiff_t i = 0; i < func_h->count; i++) declare_function (HASH_VALUE (func_h, i)); /* Compile all functions. Can't be done before because the commit 37a04737218281fecf7b4e8b9a58839e25f02815 Author: Andrea Corallo Date: Mon Nov 11 17:12:58 2019 +0100 XFIXNUM return EMACS_INT diff --git a/src/comp.c b/src/comp.c index f72d25a6ba..278bf82e6b 100644 --- a/src/comp.c +++ b/src/comp.c @@ -55,7 +55,6 @@ along with GNU Emacs. If not, see . */ #define THIRD(x) \ XCAR (XCDR (XCDR (x))) -/* FIXME with call1 */ #define FUNCALL1(fun, arg) \ CALLN (Ffuncall, intern_c_string (STR(fun)), arg) @@ -1137,8 +1136,8 @@ emit_limple_call_ref (Lisp_Object insn, bool direct) #s(comp-mvar 2 11 t 10 integer t)). */ Lisp_Object callee = FIRST (insn); - EMACS_UINT nargs = XFIXNUM (Flength (CDR (insn))); - EMACS_UINT base_ptr = XFIXNUM (FUNCALL1 (comp-mvar-slot, SECOND (insn))); + EMACS_INT nargs = XFIXNUM (Flength (CDR (insn))); + EMACS_INT base_ptr = XFIXNUM (FUNCALL1 (comp-mvar-slot, SECOND (insn))); return emit_call_ref (callee, nargs, comp.frame[base_ptr], direct); } @@ -1352,7 +1351,7 @@ emit_limple_insn (Lisp_Object insn) else if (EQ (op, Qset_par_to_local)) { /* Ex: (setpar #s(comp-mvar 2 0 nil nil nil) 0). */ - EMACS_UINT param_n = XFIXNUM (arg[1]); + EMACS_INT param_n = XFIXNUM (arg[1]); gcc_jit_rvalue *param = gcc_jit_param_as_rvalue (gcc_jit_function_get_param (comp.func, param_n)); @@ -1380,7 +1379,7 @@ emit_limple_insn (Lisp_Object insn) C: local[2] = list (nargs - 2, args); */ - EMACS_UINT slot_n = XFIXNUM (FUNCALL1 (comp-mvar-slot, arg[0])); + EMACS_INT slot_n = XFIXNUM (FUNCALL1 (comp-mvar-slot, arg[0])); gcc_jit_rvalue *n = gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.ptrdiff_type, @@ -1753,7 +1752,7 @@ emit_ctxt_code (void) declare_runtime_imported_data (); /* Imported objects. */ - EMACS_UINT d_reloc_len = + EMACS_INT d_reloc_len = XFIXNUM (FUNCALL1 (hash-table-count, FUNCALL1 (comp-ctxt-data-relocs-idx, Vcomp_ctxt))); Lisp_Object d_reloc = Fnreverse (FUNCALL1 (comp-ctxt-data-relocs-l, Vcomp_ctxt)); @@ -1775,7 +1774,7 @@ emit_ctxt_code (void) /* Imported functions from non Lisp code. */ Lisp_Object f_runtime = declare_runtime_imported_funcs (); - EMACS_UINT f_reloc_len = XFIXNUM (Flength (f_runtime)); + EMACS_INT f_reloc_len = XFIXNUM (Flength (f_runtime)); /* Imported subrs. */ Lisp_Object f_subr = FUNCALL1 (comp-ctxt-func-relocs-l, Vcomp_ctxt); @@ -2595,7 +2594,7 @@ define_PSEUDOVECTORP (void) comp.block = ret_false_b; gcc_jit_block_end_with_return (ret_false_b, NULL, - gcc_jit_context_new_rvalue_from_int( + gcc_jit_context_new_rvalue_from_int ( comp.ctxt, comp.bool_type, false)); @@ -3191,9 +3190,9 @@ load_comp_unit (dynlib_handle_ptr handle) /* Imported data. */ Lisp_Object d_vec = load_static_obj (handle, TEXT_DATA_RELOC_SYM); - EMACS_UINT d_vec_len = XFIXNUM (Flength (d_vec)); + EMACS_INT d_vec_len = XFIXNUM (Flength (d_vec)); - for (EMACS_UINT i = 0; i < d_vec_len; i++) + for (EMACS_INT i = 0; i < d_vec_len; i++) { data_relocs[i] = AREF (d_vec, i); prevent_gc (data_relocs[i]); @@ -3202,8 +3201,8 @@ load_comp_unit (dynlib_handle_ptr handle) /* Imported functions. */ Lisp_Object f_vec = load_static_obj (handle, TEXT_IMPORTED_FUNC_RELOC_SYM); - EMACS_UINT f_vec_len = XFIXNUM (Flength (f_vec)); - for (EMACS_UINT i = 0; i < f_vec_len; i++) + EMACS_INT f_vec_len = XFIXNUM (Flength (f_vec)); + for (EMACS_INT i = 0; i < f_vec_len; i++) { Lisp_Object f_sym = AREF (f_vec, i); char *f_str = SSDATA (SYMBOL_NAME (f_sym)); commit 3bc77cca86fbed8c12fb6c10c51e1237d65c9143 Author: Andrea Corallo Date: Mon Nov 11 13:19:23 2019 +0100 minimal error handling in load_comp_unit diff --git a/src/comp.c b/src/comp.c index 0e190e8887..f72d25a6ba 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3210,7 +3210,9 @@ load_comp_unit (dynlib_handle_ptr handle) Lisp_Object subr = Fsymbol_function (f_sym); if (!NILP (subr)) { - eassert (SUBRP (subr)); + /* FIXME: This is really not robust in case of subr redefinition. */ + if (!SUBRP (subr)) + error ("Native code load error, subr redefined or wrong relocation."); f_relocs[i] = XSUBR (subr)->function.a0; } else if (!strcmp (f_str, "wrong_type_argument")) { commit 13816f14b2f459a97d309f202f218282888e9bc9 Author: Andrea Corallo Date: Mon Nov 11 07:42:01 2019 +0100 propagate compiler settings to the async workers diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index a31a82dd4f..99243fda2c 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -44,7 +44,7 @@ - 1 lite optimizations. - 2 heavy optimizations. - 3 max optimization level, to be used only when necessary. - The compiler can inline within the compilation unit..." + Warning: the compiler is free to perform dangerous optimizations." :type 'number :group 'comp) @@ -1778,8 +1778,12 @@ Prepare every function for final compilation and drive the C back-end." (while (setf f (with-mutex comp-src-pool-mutex (pop comp-src-pool))) (when (comp-to-file-p f) - (let* ((cmd (concat "emacs --batch --eval=" - "'(native-compile \"" f "\")'")) + (let* ((code `(let ((comp-speed ,comp-speed) + (comp-debug ,comp-debug) + (comp-verbose ,comp-verbose)) + (native-compile ,f))) + (cmd (concat "emacs --batch --eval='" + (prin1-to-string code) "'")) (prc (start-process-shell-command (concat "async compilation: " f) "async-compile-buffer" cmd))) commit e1128305102bab268272770b4a77361dcd9efb5d Author: Andrea Corallo Date: Sun Nov 10 20:01:48 2019 +0100 add native-compile-async diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index b700a40f75..a31a82dd4f 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -53,7 +53,7 @@ - 0 no debug facility. - 1 emit debug symbols and dump pseudo C code. - 2 dump gcc passes and libgccjit log file. -- 3 dump libgccjit reproducer." +- 3 dump libgccjit reproducers." :type 'number :group 'comp) @@ -66,6 +66,11 @@ :type 'number :group 'comp) +(defcustom comp-always-compile nil + "Unconditionally (re-)compile all files." + :type 'boolean + :group 'comp) + (defconst native-compile-log-buffer "*Native-compile-Log*" "Name of the native-compiler log buffer.") @@ -1750,6 +1755,37 @@ Prepare every function for final compilation and drive the C back-end." (cl-assert (consp x))) +;; Some entry point support code. + +(defvar comp-src-pool () + "List containing the files to be compiled.") + +(defvar comp-src-pool-mutex (make-mutex) + "Mutex for `comp-src-pool'.") + +(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)))))) + +(defun comp-start-async-worker () + "Start an async compiler worker." + (make-thread + (lambda () + (let (f) + (while (setf f (with-mutex comp-src-pool-mutex + (pop comp-src-pool))) + (when (comp-to-file-p f) + (let* ((cmd (concat "emacs --batch --eval=" + "'(native-compile \"" f "\")'")) + (prc (start-process-shell-command (concat "async compilation: " f) + "async-compile-buffer" + cmd))) + (while (accept-process-output prc) + (thread-yield))))))))) + ;;; Compiler entry points. ;;;###autoload @@ -1775,6 +1811,25 @@ Return the compilation unit filename." comp-passes) data)) +;;;###autoload +(defun native-compile-async (input &optional jobs recursively) + "Compile INPUT asyncronosly. +INPUT can be either 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 (file-directory-p input) + (if recursively + (directory-files-recursively input "\\.el$") + (directory-files input t "\\.el$")) + (if (file-exists-p input) + (list input) + (error "Input not a file nor directory"))))) + (with-mutex comp-src-pool-mutex + (setf comp-src-pool (nconc files comp-src-pool))) + (cl-loop repeat jobs + do (comp-start-async-worker)))) + (provide 'comp) ;;; comp.el ends here commit 942702f506de1c7c3eff4e13470248be1a26e778 Author: Andrea Corallo Date: Sun Nov 10 18:50:45 2019 +0100 remove unused variable diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index c4529bee7c..b700a40f75 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -457,7 +457,6 @@ If INPUT is a symbol this is the function-name to be compiled. If INPUT is a string this is the file path to be compiled." (let ((byte-native-compiling t) (byte-to-native-lap ()) - (byte-to-native-bytecode ()) (byte-to-native-top-level-forms ())) (cl-typecase input (symbol (list (comp-spill-lap-function input))) commit 00c493f01703f619a62e08bea17a49ce12f2367b Author: Andrea Corallo Date: Sun Nov 10 18:50:34 2019 +0100 better doc diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index f82aefb4ef..c4529bee7c 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -38,26 +38,31 @@ "Emacs Lisp native compiler." :group 'lisp) -(defcustom comp-speed 2 - "Compiler optimization level. From 0 to 3." +(defcustom comp-speed 0 + "Compiler optimization level. From 0 to 3. +- 0 no otimizations are performed, compile time is favored. +- 1 lite optimizations. +- 2 heavy optimizations. +- 3 max optimization level, to be used only when necessary. + The compiler can inline within the compilation unit..." :type 'number :group 'comp) (defcustom comp-debug 0 "Compiler debug level. From 0 to 3. -- 0 no debug facility -- 1 emit debug symbols and dump pseudo C code -- 2 dump gcc passes and libgccjit log file -- 3 dump libgccjit reproducer" +- 0 no debug facility. +- 1 emit debug symbols and dump pseudo C code. +- 2 dump gcc passes and libgccjit log file. +- 3 dump libgccjit reproducer." :type 'number :group 'comp) (defcustom comp-verbose 0 "Compiler verbosity. From 0 to 3. -- 0 no logging -- 1 final limple is logged -- 2 LAP and final limple and some pass info are logged -- 3 max verbosity" +- 0 no logging. +- 1 final limple is logged. +- 2 LAP and final limple and some pass info are logged. +- 3 max verbosity." :type 'number :group 'comp) @@ -1752,7 +1757,7 @@ Prepare every function for final compilation and drive the C back-end." (defun native-compile (input) "Compile INPUT into native code. This is the entrypoint for the Emacs Lisp native compiler. -If INPUT is a symbol, native-compile its function definition. +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. Return the compilation unit filename." (unless (or (symbolp input) commit c9f367950652a3728cc94c7a7faf0aa55c2aae9f Author: Andrea Corallo Date: Sun Nov 10 17:07:45 2019 +0100 compile tests with debug 1 diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 6d714656ad..2e388b9f14 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -30,6 +30,7 @@ (require 'comp) (setq comp-speed 3) +(setq comp-debug 1) (defconst comp-test-src (concat (file-name-directory (or load-file-name buffer-file-name)) commit c33c2ef5119a3e1ba9c97ca03e001916f83d09f9 Author: Andrea Corallo Date: Sun Nov 10 17:02:55 2019 +0100 fix non local mechanism diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index cc7a1ba06a..f82aefb4ef 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -527,6 +527,10 @@ Restore the original value afterwards." (or (gethash label (comp-limplify-label-to-addr comp-pass)) (error "Can't find label %d" label))) +(defsubst comp-mark-curr-bb-closed () + "Mark the current basic block as closed." + (setf (comp-block-closed (comp-limplify-curr-block comp-pass)) t)) + (defun comp-bb-maybe-add (lap-addr &optional sp) "If necessary create a pending basic block for LAP-ADDR with stack depth SP. The basic block is returned regardless it was already declared or not." @@ -580,11 +584,6 @@ The basic block is returned regardless it was already declared or not." (cl-assert (not (comp-block-closed bb))) (push insn (comp-block-insns bb)))) -(defsubst comp-emit-as-head (insn bb) - "Emit INSN at the head of basic block BB. -NOTE: this is used for late fixup therefore ignore if the basic block is closed." - (setf (comp-block-insns bb) (nconc (comp-block-insns bb) (list insn)))) - (defsubst comp-emit-set-call (call) "Emit CALL assigning the result the the current slot frame. If the callee function is known to have a return type propagate it." @@ -629,7 +628,7 @@ The block is returned." (let ((target (comp-bb-maybe-add (comp-label-to-addr label-num) (comp-sp)))) (comp-emit `(jump ,(comp-block-name target))) - (setf (comp-block-closed (comp-limplify-curr-block comp-pass)) t)))) + (comp-mark-curr-bb-closed)))) (defun comp-emit-cond-jump (a b target-offset lap-label negated) "Emit a conditional jump to LAP-LABEL when A and B satisfy EQ. @@ -648,7 +647,7 @@ Return value is the fall through block name." (comp-emit (if negated (list 'cond-jump a b target bb) (list 'cond-jump a b bb target))) - (setf (comp-block-closed (comp-limplify-curr-block comp-pass)) t) + (comp-mark-curr-bb-closed) bb))) (defun comp-emit-handler (lap-label handler-type) @@ -658,14 +657,20 @@ Return value is the fall through block name." (let* ((guarded-bb (comp-bb-maybe-add (1+ (comp-limplify-pc comp-pass)) (comp-sp))) (handler-bb (comp-bb-maybe-add (comp-label-to-addr label-num) - (1+ (comp-sp))))) + (1+ (comp-sp)))) + (pop-bb (make--comp-block nil (comp-sp) (comp-new-block-sym)))) (comp-emit (list 'push-handler handler-type (comp-slot+1) - (comp-block-name handler-bb) + (comp-block-name pop-bb) (comp-block-name guarded-bb))) - (setf (comp-block-closed (comp-limplify-curr-block comp-pass)) t) - (comp-emit-as-head `(fetch-handler ,(comp-slot+1)) handler-bb)))) + (comp-mark-curr-bb-closed) + ;; Emit the basic block to pop the handler if we got the non local. + (puthash (comp-block-name pop-bb) pop-bb (comp-func-blocks comp-func)) + (setf (comp-limplify-curr-block comp-pass) pop-bb) + (comp-emit `(fetch-handler ,(comp-slot+1))) + (comp-emit `(jump ,(comp-block-name handler-bb))) + (comp-mark-curr-bb-closed)))) (defun comp-limplify-listn (n) "Limplify list N." diff --git a/src/comp.c b/src/comp.c index 969495eb93..0e190e8887 100644 --- a/src/comp.c +++ b/src/comp.c @@ -2807,7 +2807,7 @@ compile_function (Lisp_Object func) comp.loc_handler = gcc_jit_function_new_local (comp.func, NULL, comp.handler_ptr_type, - "handler"); + "c"); comp.func_blocks_h = CALLN (Fmake_hash_table); commit d5ffb4949044ae58fb418b1b214cc7c6eb16a29c Author: Andrea Corallo Date: Sun Nov 10 14:51:38 2019 +0100 better comp-debug customize diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index f87d4bc401..cc7a1ba06a 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -42,6 +42,16 @@ "Compiler optimization level. From 0 to 3." :type 'number :group 'comp) + +(defcustom comp-debug 0 + "Compiler debug level. From 0 to 3. +- 0 no debug facility +- 1 emit debug symbols and dump pseudo C code +- 2 dump gcc passes and libgccjit log file +- 3 dump libgccjit reproducer" + :type 'number + :group 'comp) + (defcustom comp-verbose 0 "Compiler verbosity. From 0 to 3. - 0 no logging diff --git a/src/comp.c b/src/comp.c index 7fa55b1247..969495eb93 100644 --- a/src/comp.c +++ b/src/comp.c @@ -34,8 +34,6 @@ along with GNU Emacs. If not, see . */ #include "buffer.h" #include "blockinput.h" -#define COMP_DEBUG 1 - /* C symbols emited for the load relocation mechanism. */ #define CURRENT_THREAD_RELOC_SYM "current_thread_reloc" #define PURE_RELOC_SYM "pure_reloc" @@ -44,6 +42,9 @@ along with GNU Emacs. If not, see . */ #define TEXT_DATA_RELOC_SYM "text_data_reloc" #define TEXT_IMPORTED_FUNC_RELOC_SYM "text_imported_funcs" +#define SPEED XFIXNUM (Fsymbol_value (Qcomp_speed)) +#define COMP_DEBUG XFIXNUM (Fsymbol_value (Qcomp_debug)) + #define STR_VALUE(s) #s #define STR(s) STR_VALUE (s) @@ -3070,7 +3071,7 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, gcc_jit_context_dump_to_file (comp.ctxt, format_string ("%s.c", SSDATA (ctxtname)), 1); - if (COMP_DEBUG > 1) + if (COMP_DEBUG > 2) gcc_jit_context_dump_reproducer_to_file (comp.ctxt, "comp_reproducer.c"); AUTO_STRING (dot_so, NATIVE_ELISP_SUFFIX); @@ -3312,6 +3313,7 @@ syms_of_comp (void) { /* Compiler control customize. */ DEFSYM (Qcomp_speed, "comp-speed"); + DEFSYM (Qcomp_debug, "comp-debug"); /* Limple instruction set. */ DEFSYM (Qcomment, "comment"); DEFSYM (Qjump, "jump"); commit f9ea53442e6f492f1543a5e21479e72be8eff4c3 Author: Andrea Corallo Date: Sun Nov 10 14:43:47 2019 +0100 move speed definition into lisp code diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 4b15bb1f8a..f87d4bc401 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -38,6 +38,10 @@ "Emacs Lisp native compiler." :group 'lisp) +(defcustom comp-speed 2 + "Compiler optimization level. From 0 to 3." + :type 'number + :group 'comp) (defcustom comp-verbose 0 "Compiler verbosity. From 0 to 3. - 0 no logging diff --git a/src/comp.c b/src/comp.c index 8793f7b856..7fa55b1247 100644 --- a/src/comp.c +++ b/src/comp.c @@ -34,8 +34,6 @@ along with GNU Emacs. If not, see . */ #include "buffer.h" #include "blockinput.h" -#define DEFAULT_SPEED 2 /* See comp-speed var. */ - #define COMP_DEBUG 1 /* C symbols emited for the load relocation mechanism. */ @@ -287,7 +285,7 @@ get_slot (Lisp_Object mvar) { EMACS_INT slot_n = XFIXNUM (FUNCALL1 (comp-mvar-slot, mvar)); gcc_jit_lvalue **frame = - (FUNCALL1 (comp-mvar-ref, mvar) || comp_speed < 2) + (FUNCALL1 (comp-mvar-ref, mvar) || SPEED < 2) ? comp.frame : comp.f_frame; return frame[slot_n]; } @@ -2794,7 +2792,7 @@ compile_function (Lisp_Object func) - Allow gcc to trigger other optimizations that are prevented by memory referencing. */ - if (comp_speed >= 2) + if (SPEED >= 2) { comp.f_frame = SAFE_ALLOCA (frame_size * sizeof (*comp.f_frame)); for (unsigned i = 0; i < frame_size; ++i) @@ -3036,7 +3034,7 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, gcc_jit_context_set_int_option (comp.ctxt, GCC_JIT_INT_OPTION_OPTIMIZATION_LEVEL, - comp_speed); + SPEED); /* Gcc doesn't like being interrupted at all. */ block_input (); sigset_t oldset; @@ -3312,6 +3310,8 @@ DEFUN ("native-elisp-load", Fnative_elisp_load, Snative_elisp_load, 1, 1, 0, void syms_of_comp (void) { + /* Compiler control customize. */ + DEFSYM (Qcomp_speed, "comp-speed"); /* Limple instruction set. */ DEFSYM (Qcomment, "comment"); DEFSYM (Qjump, "jump"); @@ -3376,13 +3376,10 @@ syms_of_comp (void) staticpro (&comp.emitter_dispatcher); comp.emitter_dispatcher = Qnil; - DEFVAR_INT ("comp-speed", comp_speed, - doc: /* From 0 to 3. */); DEFVAR_LISP ("comp-ctxt", Vcomp_ctxt, doc: /* The compiler context. */); Vcomp_ctxt = Qnil; - comp_speed = DEFAULT_SPEED; /* Load mechanism. */ staticpro (&Vnative_elisp_refs_hash); commit aee75b87719abfaed605e33ed0c9e3a9a81417d8 Author: Andrea Corallo Date: Sun Nov 10 14:30:33 2019 +0100 fix two nits diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 5283e57669..4b15bb1f8a 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -244,8 +244,6 @@ structure.") (ref nil :type boolean :documentation "When t this is used by reference.")) -(defvar comp-ctxt) ;; FIXME (to be removed) - ;; Special vars used by some passes (defvar comp-func) diff --git a/test/src/comp-test-funcs.el b/test/src/comp-test-funcs.el index 6127d24e65..5f33eacdb2 100644 --- a/test/src/comp-test-funcs.el +++ b/test/src/comp-test-funcs.el @@ -26,7 +26,7 @@ (defvar comp-tests-var1 3) (defun comp-tests-varref-f () - comp-tests-var1) + comp-tests-var1) (defun comp-tests-list-f () (list 1 2 3)) commit 76dd30a98590f2266290a70f2e3d4d272c092310 Author: Andrea Corallo Date: Sun Nov 10 14:25:17 2019 +0100 fix again comp-copy-insn diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index b450f4d6f6..5283e57669 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1439,13 +1439,20 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non nil." (defun comp-copy-insn (insn) "Deep copy INSN." - (cond - ((and (listp insn) (listp (cdr insn))) - (mapcar #'comp-copy-insn insn)) - ((consp insn) ; Pair - (cons (car insn) (cdr insn))) - ((comp-mvar-p insn) (copy-comp-mvar insn)) - (t insn))) + ;; Adapted from `copy-tree'. + (if (consp insn) + (let (result) + (while (consp insn) + (let ((newcar (car insn))) + (if (or (consp (car insn)) (comp-mvar-p (car insn))) + (setq newcar (comp-copy-insn (car insn)))) + (push newcar result)) + (setq insn (cdr insn))) + (nconc (nreverse result) + (if (comp-mvar-p insn) (comp-copy-insn insn) insn))) + (if (comp-mvar-p insn) + (copy-comp-mvar insn) + insn))) (defun comp-basic-const-propagate () "Propagate simple constants for setimm operands. commit e176d04d45adbb51f6bfa0b5a0352927056f3519 Author: Andrea Corallo Date: Sun Nov 10 13:10:31 2019 +0100 fix SIGIO hang after compilation diff --git a/src/comp.c b/src/comp.c index cce4f1d6e5..8793f7b856 100644 --- a/src/comp.c +++ b/src/comp.c @@ -32,6 +32,7 @@ along with GNU Emacs. If not, see . */ #include "window.h" #include "dynlib.h" #include "buffer.h" +#include "blockinput.h" #define DEFAULT_SPEED 2 /* See comp-speed var. */ @@ -3037,6 +3038,7 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, GCC_JIT_INT_OPTION_OPTIMIZATION_LEVEL, comp_speed); /* Gcc doesn't like being interrupted at all. */ + block_input (); sigset_t oldset; sigset_t blocked; sigemptyset (&blocked); @@ -3081,6 +3083,7 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, SSDATA (out_file)); pthread_sigmask (SIG_SETMASK, &oldset, 0); + unblock_input (); return out_file; } commit 26aeca29801a8e8950141d9d54aeb9a22ee6c5ad Author: Andrea Corallo Date: Sun Nov 10 11:35:49 2019 +0100 fix comp-copy-insn for dotted pairs diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 377886996e..b450f4d6f6 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1439,11 +1439,13 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non nil." (defun comp-copy-insn (insn) "Deep copy INSN." - (cl-loop for op in insn - collect (cl-typecase op - (cons (comp-copy-insn op)) - (comp-mvar (copy-comp-mvar op)) - (t op)))) + (cond + ((and (listp insn) (listp (cdr insn))) + (mapcar #'comp-copy-insn insn)) + ((consp insn) ; Pair + (cons (car insn) (cdr insn))) + ((comp-mvar-p insn) (copy-comp-mvar insn)) + (t insn))) (defun comp-basic-const-propagate () "Propagate simple constants for setimm operands. commit 2ee2c67736cd76a52a2eb1002d0ec15e883082e0 Author: Andrea Corallo Date: Sun Nov 10 10:17:24 2019 +0100 simplify non local exit handler mechanism diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index cb001bc884..377886996e 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -221,9 +221,7 @@ structure.") (edge-cnt-gen (funcall #'comp-gen-counter) :type function :documentation "Generates edges numbers.") (ssa-cnt-gen (funcall #'comp-gen-counter) :type function - :documentation "Counter to create ssa limple vars.") - (handler-cnt 0 :type number - :documentation "Number of non local handler buffers.")) + :documentation "Counter to create ssa limple vars.")) (defun comp-func-reset-generators (func) "Reset unique id generators for FUNC." @@ -648,17 +646,14 @@ Return value is the fall through block name." (let* ((guarded-bb (comp-bb-maybe-add (1+ (comp-limplify-pc comp-pass)) (comp-sp))) (handler-bb (comp-bb-maybe-add (comp-label-to-addr label-num) - (1+ (comp-sp)))) - (handler-buff-n (comp-func-handler-cnt comp-func))) + (1+ (comp-sp))))) (comp-emit (list 'push-handler handler-type (comp-slot+1) - handler-buff-n (comp-block-name handler-bb) (comp-block-name guarded-bb))) (setf (comp-block-closed (comp-limplify-curr-block comp-pass)) t) - (comp-emit-as-head `(fetch-handler ,(comp-slot+1) ,handler-buff-n) handler-bb) - (cl-incf (comp-func-handler-cnt comp-func))))) + (comp-emit-as-head `(fetch-handler ,(comp-slot+1)) handler-bb)))) (defun comp-limplify-listn (n) "Limplify list N." @@ -1181,7 +1176,7 @@ Top level forms for the current context are rendered too." (cl-loop with blocks = (comp-func-blocks comp-func) for bb being each hash-value of blocks for last-insn = (car (last (comp-block-insns bb))) - for (op first second third forth fifth) = last-insn + for (op first second third forth) = last-insn do (cl-case op (jump (edge-add :src bb :dst (gethash first blocks))) @@ -1192,8 +1187,8 @@ Top level forms for the current context are rendered too." (edge-add :src bb :dst (gethash second blocks)) (edge-add :src bb :dst (gethash third blocks))) (push-handler - (edge-add :src bb :dst (gethash forth blocks)) - (edge-add :src bb :dst (gethash fifth blocks))) + (edge-add :src bb :dst (gethash third blocks)) + (edge-add :src bb :dst (gethash forth blocks))) (return) (otherwise (error "Block %s does not end with a branch in func %s" diff --git a/src/comp.c b/src/comp.c index 07c35413dd..cce4f1d6e5 100644 --- a/src/comp.c +++ b/src/comp.c @@ -55,6 +55,7 @@ along with GNU Emacs. If not, see . */ #define THIRD(x) \ XCAR (XCDR (XCDR (x))) +/* FIXME with call1 */ #define FUNCALL1(fun, arg) \ CALLN (Ffuncall, intern_c_string (STR(fun)), arg) @@ -114,6 +115,7 @@ typedef struct { gcc_jit_field *handler_val_field; gcc_jit_field *handler_next_field; gcc_jit_type *handler_ptr_type; + gcc_jit_lvalue *loc_handler; /* struct thread_state. */ gcc_jit_struct *thread_state_s; gcc_jit_field *m_handlerlist; @@ -161,7 +163,6 @@ typedef struct { Lisp_Object func_blocks_h; /* blk_name -> gcc_block. */ Lisp_Object exported_funcs_h; /* subr_name -> gcc_jit_function *. */ Lisp_Object imported_funcs_h; /* subr_name -> reloc_field. */ - Lisp_Object buffer_handler_vec; /* All locals used to store non local exit values. */ Lisp_Object emitter_dispatcher; gcc_jit_rvalue *data_relocs; /* Synthesized struct holding data relocs. */ gcc_jit_lvalue *func_relocs; /* Synthesized struct holding func relocs. */ @@ -1145,25 +1146,23 @@ emit_limple_call_ref (Lisp_Object insn, bool direct) static void emit_limple_push_handler (gcc_jit_rvalue *handler, gcc_jit_rvalue *handler_type, - EMACS_UINT handler_buff_n, gcc_jit_block *handler_bb, - gcc_jit_block *guarded_bb, Lisp_Object clobbered_mvar) + gcc_jit_block *handler_bb, gcc_jit_block *guarded_bb, + Lisp_Object clobbered_mvar) { /* struct handler *c = push_handler (POP, type); */ - gcc_jit_lvalue *c = - xmint_pointer (AREF (comp.buffer_handler_vec, handler_buff_n)); gcc_jit_rvalue *args[] = { handler, handler_type }; gcc_jit_block_add_assignment ( comp.block, NULL, - c, + comp.loc_handler, emit_call (intern_c_string ("push_handler"), comp.handler_ptr_type, 2, args, false)); args[0] = gcc_jit_lvalue_get_address ( gcc_jit_rvalue_dereference_field ( - gcc_jit_lvalue_as_rvalue (c), + gcc_jit_lvalue_as_rvalue (comp.loc_handler), NULL, comp.handler_jmp_field), NULL); @@ -1236,10 +1235,9 @@ emit_limple_insn (Lisp_Object insn) else if (EQ (op, Qpush_handler)) { /* (push-handler condition-case #s(comp-mvar 0 3 t (arith-error) cons nil) 1 bb_2 bb_1) */ - gcc_jit_rvalue *handler = emit_mvar_val (arg[1]); int h_num UNINIT; Lisp_Object handler_spec = arg[0]; - EMACS_UINT handler_buff_n = XFIXNUM (arg[2]); + gcc_jit_rvalue *handler = emit_mvar_val (arg[1]); if (EQ (handler_spec, Qcatcher)) h_num = CATCHER; else if (EQ (handler_spec, Qcondition_case)) @@ -1250,10 +1248,10 @@ emit_limple_insn (Lisp_Object insn) gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.int_type, h_num); - gcc_jit_block *handler_bb = retrive_block (arg[3]); - gcc_jit_block *guarded_bb = retrive_block (arg[4]); - emit_limple_push_handler (handler, handler_type, handler_buff_n, - handler_bb, guarded_bb, arg[0]); + gcc_jit_block *handler_bb = retrive_block (arg[2]); + gcc_jit_block *guarded_bb = retrive_block (arg[3]); + emit_limple_push_handler (handler, handler_type, handler_bb, guarded_bb, + arg[0]); } else if (EQ (op, Qpop_handler)) { @@ -1281,29 +1279,33 @@ emit_limple_insn (Lisp_Object insn) } else if (EQ (op, Qfetch_handler)) { - EMACS_UINT handler_buff_n = XFIXNUM (arg[1]); - gcc_jit_lvalue *c = - xmint_pointer (AREF (comp.buffer_handler_vec, handler_buff_n)); gcc_jit_lvalue *m_handlerlist = gcc_jit_rvalue_dereference_field ( gcc_jit_lvalue_as_rvalue ( gcc_jit_rvalue_dereference (comp.current_thread_ref, NULL)), - NULL, - comp.m_handlerlist); + NULL, + comp.m_handlerlist); + gcc_jit_block_add_assignment (comp.block, + NULL, + comp.loc_handler, + gcc_jit_lvalue_as_rvalue (m_handlerlist)); + gcc_jit_block_add_assignment ( comp.block, NULL, m_handlerlist, gcc_jit_lvalue_as_rvalue( - gcc_jit_rvalue_dereference_field (gcc_jit_lvalue_as_rvalue (c), - NULL, - comp.handler_next_field))); + gcc_jit_rvalue_dereference_field ( + gcc_jit_lvalue_as_rvalue (comp.loc_handler), + NULL, + comp.handler_next_field))); emit_frame_assignment ( arg[0], gcc_jit_lvalue_as_rvalue( - gcc_jit_rvalue_dereference_field (gcc_jit_lvalue_as_rvalue (c), - NULL, - comp.handler_val_field))); + gcc_jit_rvalue_dereference_field ( + gcc_jit_lvalue_as_rvalue (comp.loc_handler), + NULL, + comp.handler_val_field))); } else if (EQ (op, Qcall)) { @@ -2802,15 +2804,10 @@ compile_function (Lisp_Object func) format_string ("local%u", i)); } - EMACS_UINT non_local_handlers = XFIXNUM (FUNCALL1 (comp-func-handler-cnt, func)); - comp.buffer_handler_vec = make_vector (non_local_handlers, Qnil); - for (unsigned i = 0; i < non_local_handlers; ++i) - ASET (comp.buffer_handler_vec, i, - make_mint_ptr ( - gcc_jit_function_new_local (comp.func, - NULL, - comp.handler_ptr_type, - format_string ("handler_%u", i)))); + comp.loc_handler = gcc_jit_function_new_local (comp.func, + NULL, + comp.handler_ptr_type, + "handler"); comp.func_blocks_h = CALLN (Fmake_hash_table); commit 105e7180230dc22db91af2c8cbfa6fc3d2fee7e6 Author: Andrea Corallo Date: Sun Nov 10 09:32:56 2019 +0100 sanity check during eln load diff --git a/src/comp.c b/src/comp.c index 80a59faa85..07c35413dd 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3175,15 +3175,22 @@ load_comp_unit (dynlib_handle_ptr handle) { struct thread_state ***current_thread_reloc = dynlib_sym (handle, CURRENT_THREAD_RELOC_SYM); - *current_thread_reloc = ¤t_thread; + EMACS_INT ***pure_reloc = dynlib_sym (handle, PURE_RELOC_SYM); + Lisp_Object *data_relocs = dynlib_sym (handle, DATA_RELOC_SYM); + Lisp_Object (**f_relocs)(void) = dynlib_sym (handle, IMPORTED_FUNC_RELOC_SYM); + void (*top_level_run)(void) = dynlib_sym (handle, "top_level_run"); + + if (!(current_thread_reloc + && pure_reloc + && data_relocs + && f_relocs + && top_level_run)) + return -1; - EMACS_INT ***pure_reloc = - dynlib_sym (handle, PURE_RELOC_SYM); + *current_thread_reloc = ¤t_thread; *pure_reloc = (EMACS_INT **)&pure; /* Imported data. */ - Lisp_Object *data_relocs = dynlib_sym (handle, DATA_RELOC_SYM); - Lisp_Object d_vec = load_static_obj (handle, TEXT_DATA_RELOC_SYM); EMACS_UINT d_vec_len = XFIXNUM (Flength (d_vec)); @@ -3194,8 +3201,6 @@ load_comp_unit (dynlib_handle_ptr handle) } /* Imported functions. */ - Lisp_Object (**f_relocs)(void) = - dynlib_sym (handle, IMPORTED_FUNC_RELOC_SYM); Lisp_Object f_vec = load_static_obj (handle, TEXT_IMPORTED_FUNC_RELOC_SYM); EMACS_UINT f_vec_len = XFIXNUM (Flength (f_vec)); @@ -3251,7 +3256,6 @@ load_comp_unit (dynlib_handle_ptr handle) } /* Executing this will perform all the expected environment modification. */ - void (*top_level_run)(void) = dynlib_sym (handle, "top_level_run"); top_level_run (); return 0; commit 3ed524c908d4aefd174ae6a8adc2bdaabb4bc4da Author: Andrea Corallo Date: Sun Nov 10 09:26:17 2019 +0100 add pure addr relocation mechanism diff --git a/src/comp.c b/src/comp.c index 04a63c1aec..80a59faa85 100644 --- a/src/comp.c +++ b/src/comp.c @@ -39,6 +39,7 @@ along with GNU Emacs. If not, see . */ /* C symbols emited for the load relocation mechanism. */ #define CURRENT_THREAD_RELOC_SYM "current_thread_reloc" +#define PURE_RELOC_SYM "pure_reloc" #define DATA_RELOC_SYM "d_reloc" #define IMPORTED_FUNC_RELOC_SYM "f_reloc" #define TEXT_DATA_RELOC_SYM "text_data_reloc" @@ -119,7 +120,7 @@ typedef struct { gcc_jit_type *thread_state_ptr_type; gcc_jit_rvalue *current_thread_ref; /* other globals */ - gcc_jit_rvalue *pure; + gcc_jit_rvalue *pure_ref; /* libgccjit has really limited support for casting therefore this union will be used for the scope. */ gcc_jit_type *cast_union_type; @@ -1000,7 +1001,9 @@ emit_PURE_P (gcc_jit_rvalue *ptr) GCC_JIT_BINARY_OP_MINUS, comp.uintptr_type, emit_cast (comp.uintptr_type, ptr), - emit_cast (comp.uintptr_type, comp.pure)), + emit_cast (comp.uintptr_type, + gcc_jit_lvalue_as_rvalue ( + gcc_jit_rvalue_dereference (comp.pure_ref, NULL)))), gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.uintptr_type, PURESIZE)); @@ -1737,6 +1740,15 @@ emit_ctxt_code (void) gcc_jit_type_get_pointer (comp.thread_state_ptr_type), CURRENT_THREAD_RELOC_SYM)); + comp.pure_ref = + gcc_jit_lvalue_as_rvalue ( + gcc_jit_context_new_global ( + comp.ctxt, + NULL, + GCC_JIT_GLOBAL_EXPORTED, + gcc_jit_type_get_pointer (comp.void_ptr_type), + PURE_RELOC_SYM)); + declare_runtime_imported_data (); /* Imported objects. */ EMACS_UINT d_reloc_len = @@ -2998,11 +3010,6 @@ DEFUN ("comp--init-ctxt", Fcomp__init_ctxt, Scomp__init_ctxt, define_thread_state_struct (); define_cast_union (); - /* FIXME!! */ - comp.pure = - gcc_jit_context_new_rvalue_from_ptr (comp.ctxt, - comp.void_ptr_type, - pure); return Qt; } @@ -3170,6 +3177,10 @@ load_comp_unit (dynlib_handle_ptr handle) dynlib_sym (handle, CURRENT_THREAD_RELOC_SYM); *current_thread_reloc = ¤t_thread; + EMACS_INT ***pure_reloc = + dynlib_sym (handle, PURE_RELOC_SYM); + *pure_reloc = (EMACS_INT **)&pure; + /* Imported data. */ Lisp_Object *data_relocs = dynlib_sym (handle, DATA_RELOC_SYM); commit c47892201b2b9f1ef903ff2a12bb9ed9e64d19de Author: Andrea Corallo Date: Sun Nov 10 08:58:48 2019 +0100 add current thread missing reloc mechanism diff --git a/src/comp.c b/src/comp.c index 273d8aeac3..04a63c1aec 100644 --- a/src/comp.c +++ b/src/comp.c @@ -38,6 +38,7 @@ along with GNU Emacs. If not, see . */ #define COMP_DEBUG 1 /* C symbols emited for the load relocation mechanism. */ +#define CURRENT_THREAD_RELOC_SYM "current_thread_reloc" #define DATA_RELOC_SYM "d_reloc" #define IMPORTED_FUNC_RELOC_SYM "f_reloc" #define TEXT_DATA_RELOC_SYM "text_data_reloc" @@ -116,7 +117,7 @@ typedef struct { gcc_jit_struct *thread_state_s; gcc_jit_field *m_handlerlist; gcc_jit_type *thread_state_ptr_type; - gcc_jit_rvalue *current_thread; + gcc_jit_rvalue *current_thread_ref; /* other globals */ gcc_jit_rvalue *pure; /* libgccjit has really limited support for casting therefore this union will @@ -1258,9 +1259,11 @@ emit_limple_insn (Lisp_Object insn) current_thread->m_handlerlist->next; */ gcc_jit_lvalue *m_handlerlist = - gcc_jit_rvalue_dereference_field (comp.current_thread, - NULL, - comp.m_handlerlist); + gcc_jit_rvalue_dereference_field ( + gcc_jit_lvalue_as_rvalue ( + gcc_jit_rvalue_dereference (comp.current_thread_ref, NULL)), + NULL, + comp.m_handlerlist); gcc_jit_block_add_assignment( comp.block, @@ -1279,7 +1282,9 @@ emit_limple_insn (Lisp_Object insn) gcc_jit_lvalue *c = xmint_pointer (AREF (comp.buffer_handler_vec, handler_buff_n)); gcc_jit_lvalue *m_handlerlist = - gcc_jit_rvalue_dereference_field (comp.current_thread, + gcc_jit_rvalue_dereference_field ( + gcc_jit_lvalue_as_rvalue ( + gcc_jit_rvalue_dereference (comp.current_thread_ref, NULL)), NULL, comp.m_handlerlist); gcc_jit_block_add_assignment ( @@ -1723,6 +1728,15 @@ emit_ctxt_code (void) { USE_SAFE_ALLOCA; + comp.current_thread_ref = + gcc_jit_lvalue_as_rvalue ( + gcc_jit_context_new_global ( + comp.ctxt, + NULL, + GCC_JIT_GLOBAL_EXPORTED, + gcc_jit_type_get_pointer (comp.thread_state_ptr_type), + CURRENT_THREAD_RELOC_SYM)); + declare_runtime_imported_data (); /* Imported objects. */ EMACS_UINT d_reloc_len = @@ -2984,15 +2998,11 @@ DEFUN ("comp--init-ctxt", Fcomp__init_ctxt, Scomp__init_ctxt, define_thread_state_struct (); define_cast_union (); - comp.current_thread = - gcc_jit_context_new_rvalue_from_ptr (comp.ctxt, - comp.thread_state_ptr_type, - current_thread); + /* FIXME!! */ comp.pure = gcc_jit_context_new_rvalue_from_ptr (comp.ctxt, comp.void_ptr_type, pure); - return Qt; } @@ -3156,6 +3166,10 @@ load_static_obj (dynlib_handle_ptr handle, const char *name) static int load_comp_unit (dynlib_handle_ptr handle) { + struct thread_state ***current_thread_reloc = + dynlib_sym (handle, CURRENT_THREAD_RELOC_SYM); + *current_thread_reloc = ¤t_thread; + /* Imported data. */ Lisp_Object *data_relocs = dynlib_sym (handle, DATA_RELOC_SYM); commit 6d230fc2c04532b4abf2474411b2995c237d5cc8 Author: Andrea Corallo Date: Sat Nov 9 18:01:16 2019 +0100 comment unused functions diff --git a/src/comp.c b/src/comp.c index 4afba1183f..273d8aeac3 100644 --- a/src/comp.c +++ b/src/comp.c @@ -515,6 +515,7 @@ emit_lval_XLI (gcc_jit_lvalue *obj) comp.lisp_obj_as_num); } +/* static gcc_jit_rvalue * emit_XLP (gcc_jit_rvalue *obj) { @@ -533,8 +534,7 @@ emit_lval_XLP (gcc_jit_lvalue *obj) return gcc_jit_lvalue_access_field (obj, NULL, comp.lisp_obj_as_ptr); -} - +} */ static gcc_jit_rvalue * emit_XUNTAG (gcc_jit_rvalue *a, gcc_jit_type *type, unsigned lisp_word_tag) { commit ce4375f57f9b89d68fb639590f3e4a0a28e3a627 Author: Andrea Corallo Date: Sat Nov 9 17:12:56 2019 +0100 two doc nits diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index dabf6cf99a..cb001bc884 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -39,7 +39,7 @@ :group 'lisp) (defcustom comp-verbose 0 - "Compiler verbosity. From 0 to 3. + "Compiler verbosity. From 0 to 3. - 0 no logging - 1 final limple is logged - 2 LAP and final limple and some pass info are logged @@ -48,7 +48,7 @@ :group 'comp) (defconst native-compile-log-buffer "*Native-compile-Log*" - "Name of the native-compiler's log buffer.") + "Name of the native-compiler log buffer.") (defvar comp-native-compiling nil "This gets bound to t while native compilation. @@ -301,7 +301,7 @@ BODY is evaluate only if `comp-verbose' is > 0." ,@body)))) (defun comp-log (data verbosity) - "Log DATA." + "Log DATA given VERBOSITY." (when (>= comp-verbose verbosity) (if noninteractive (if (atom data) @@ -650,7 +650,6 @@ Return value is the fall through block name." (handler-bb (comp-bb-maybe-add (comp-label-to-addr label-num) (1+ (comp-sp)))) (handler-buff-n (comp-func-handler-cnt comp-func))) - (comp-emit (list 'push-handler handler-type (comp-slot+1) commit 6a34ff5d9c13688a7264b2654f04982c5a3cfc6b Author: Andrea Corallo Date: Sat Nov 9 16:56:55 2019 +0100 rework log mechanism and trim down verbosity diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 08ccfbb97d..dabf6cf99a 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -42,8 +42,8 @@ "Compiler verbosity. From 0 to 3. - 0 no logging - 1 final limple is logged -- 2 LAP and final limple are logged -- 3 all passes are dumping" +- 2 LAP and final limple and some pass info are logged +- 3 max verbosity" :type 'number :group 'comp) @@ -300,43 +300,46 @@ BODY is evaluate only if `comp-verbose' is > 0." (goto-char (point-max)) ,@body)))) -(defun comp-log (data) +(defun comp-log (data verbosity) "Log DATA." - (if (and noninteractive - (> comp-verbose 0)) - (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"))))) - -(defun comp-log-func (func) + (when (>= comp-verbose verbosity) + (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")))))) + +(defun comp-log-func (func verbosity) "Log function FUNC." - (comp-log (format "\nFunction: %s" (comp-func-symbol-name func))) - (cl-loop for block-name being each hash-keys of (comp-func-blocks func) - using (hash-value bb) - do (comp-log (concat "<" (symbol-name block-name) ">\n")) - (comp-log (comp-block-insns bb)))) + (when (>= comp-verbose verbosity) + (comp-log (format "\nFunction: %s\n" (comp-func-symbol-name func)) verbosity) + (cl-loop for block-name being each hash-keys of (comp-func-blocks func) + using (hash-value bb) + do (comp-log (concat "<" (symbol-name block-name) ">\n") verbosity) + (comp-log (comp-block-insns bb) verbosity)))) (defun comp-log-edges (func) "Log edges in FUNC." (let ((edges (comp-func-edges func))) (when (> comp-verbose 2) (comp-log (format "\nEdges in function: %s\n" - (comp-func-symbol-name func)))) + (comp-func-symbol-name func)) + 0)) (mapc (lambda (e) (when (> comp-verbose 2) (comp-log (format "n: %d src: %s dst: %s\n" (comp-edge-number e) (comp-block-name (comp-edge-src e)) - (comp-block-name (comp-edge-dst e)))))) + (comp-block-name (comp-edge-dst e))) + 0))) edges))) @@ -429,9 +432,8 @@ Put PREFIX in front of it." :args (comp-decrypt-lambda-list lambda-list) :lap lap :frame-size (comp-byte-frame-size data)) - when (> comp-verbose 1) - do (comp-log (format "Function %s:\n" name)) - (comp-log lap) + do (comp-log (format "Function %s:\n" name) 1) + (comp-log lap 1) collect func)) (defun comp-spill-lap (input) @@ -1023,8 +1025,7 @@ the annotation emission." (cl-loop for bb being the hash-value in (comp-func-blocks func) do (setf (comp-block-insns bb) (nreverse (comp-block-insns bb)))) - (when (> comp-verbose 2) - (comp-log-func func)) + (comp-log-func func 2) func) (cl-defgeneric comp-emit-for-top-level (form) @@ -1252,8 +1253,7 @@ Top level forms for the current context are rendered too." with changed = t while changed initially (progn - (when (> comp-verbose 2) - (comp-log "Computing dominator tree...\n")) + (comp-log "Computing dominator tree...\n" 2) (setf (comp-block-dom entry) entry) ;; Set the post order number. (cl-loop for name in (reverse rev-bb-list) @@ -1292,12 +1292,12 @@ Top level forms for the current context are rendered too." (maphash (lambda (name bb) (let ((dom (comp-block-dom bb)) (df (comp-block-df bb))) - (when (> comp-verbose 2) - (comp-log (format "block: %s idom: %s DF %s\n" - name - (when dom (comp-block-name dom)) - (cl-loop for b being each hash-keys of df - collect b)))))) + (comp-log (format "block: %s idom: %s DF %s\n" + name + (when dom (comp-block-name dom)) + (cl-loop for b being each hash-keys of df + collect b)) + 3))) (comp-func-blocks comp-func))) (defun comp-place-phis () @@ -1380,8 +1380,7 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non nil." (defun comp-ssa-rename () "Entry point to rename SSA within the current function." - (when (> comp-verbose 2) - (comp-log "Renaming\n")) + (comp-log "Renaming\n" 2) (let ((frame-size (comp-func-frame-size comp-func)) (visited (make-hash-table))) (cl-labels ((ssa-rename-rec (bb in-frame) @@ -1430,8 +1429,7 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non nil." (comp-place-phis) (comp-ssa-rename) (comp-finalize-phis) - (when (> comp-verbose 2) - (comp-log-func comp-func)))) + (comp-log-func comp-func 3))) (comp-ctxt-funcs-h comp-ctxt))) @@ -1522,9 +1520,8 @@ Return t if something was changed." (cl-loop for i from 1 while (comp-propagate*) - finally (comp-log (format "Propagation run %d times\n" i))) - (when (> comp-verbose 2) - (comp-log-func comp-func)))) + finally (comp-log (format "Propagation run %d times\n" i) 2)) + (comp-log-func comp-func 3))) (comp-ctxt-funcs-h comp-ctxt))) @@ -1651,11 +1648,12 @@ Return t if something was changed." ;; Every l-value appearing that does not appear as r-value has no right to ;; exist and gets nuked. (let ((nuke-list (cl-set-difference l-vals r-vals))) - (when (> comp-verbose 2) - (comp-log (format "Function %s\n" (comp-func-symbol-name comp-func))) - (comp-log (format "l-vals %s\n" l-vals)) - (comp-log (format "r-vals %s\n" r-vals)) - (comp-log (format "Nuking ids: %s\n" nuke-list))) + (comp-log (format "Function %s\nl-vals %s\nr-vals %s\nNuking ids: %s\n" + (comp-func-symbol-name comp-func) + l-vals + r-vals + nuke-list) + 3) (cl-loop for b being each hash-value of (comp-func-blocks comp-func) do (cl-loop @@ -1689,7 +1687,7 @@ These are substituted with normals 'set'." (let ((comp-func f)) (comp-dead-assignments-func) (comp-remove-type-hints-func) - (comp-log-func comp-func))) + (comp-log-func comp-func 3))) (comp-ctxt-funcs-h comp-ctxt)))) @@ -1746,9 +1744,9 @@ Return the compilation unit filename." :output (if (symbolp input) (symbol-name input) (file-name-sans-extension (expand-file-name input)))))) - (comp-log "\n \n") + (comp-log "\n \n" 1) (mapc (lambda (pass) - (comp-log (format "Running pass %s:\n" pass)) + (comp-log (format "Running pass %s:\n" pass) 2) (setq data (funcall pass data))) comp-passes) data)) commit ec00ef8d48afaef65527c02ea013ba4489ed279d Author: Andrea Corallo Date: Sat Nov 9 16:22:07 2019 +0100 have propagate run the correct number of times diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 3d45254345..08ccfbb97d 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -230,7 +230,7 @@ structure.") (setf (comp-func-edge-cnt-gen func) (comp-gen-counter)) (setf (comp-func-ssa-cnt-gen func) (comp-gen-counter))) -(cl-defstruct (comp-mvar (:copier nil) (:constructor make--comp-mvar)) +(cl-defstruct (comp-mvar (:constructor make--comp-mvar)) "A meta-variable being a slot in the meta-stack." (slot nil :type fixnum :documentation "Slot number.") @@ -1445,6 +1445,14 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non nil." 'fixnum (type-of obj))) +(defun comp-copy-insn (insn) + "Deep copy INSN." + (cl-loop for op in insn + collect (cl-typecase op + (cons (comp-copy-insn op)) + (comp-mvar (copy-comp-mvar op)) + (t op)))) + (defun comp-basic-const-propagate () "Propagate simple constants for setimm operands. This can run just once." @@ -1465,6 +1473,7 @@ This can run just once." (setf (comp-mvar-type lval) (comp-mvar-type rval))) (defun comp-propagate-insn (insn) + "Propagate within INSN." (pcase insn (`(set ,lval ,rval) (pcase rval @@ -1494,20 +1503,28 @@ This can run just once." (mapc (lambda (x) (setf (comp-mvar-ref x) t)) operands)))))) (defun comp-propagate* () - "Propagate for set and phi operands." - (cl-loop for b being each hash-value of (comp-func-blocks comp-func) + "Propagate for set* and phi operands. +Return t if something was changed." + (cl-loop with modified = nil + for b being each hash-value of (comp-func-blocks comp-func) do (cl-loop for insn in (comp-block-insns b) - do (comp-propagate-insn insn)))) + for orig-insn = (unless modified ; Save consing after 1th change. + (comp-copy-insn insn)) + do (comp-propagate-insn insn) + when (and (null modified) (not (equal insn orig-insn))) + do (setf modified t)) + finally (cl-return modified))) (defun comp-propagate (_) (maphash (lambda (_ f) (let ((comp-func f)) (comp-basic-const-propagate) - ;; FIXME: unbelievably dumb... - (cl-loop repeat 10 - do (comp-propagate*)) - (when (> comp-verbose 2) - (comp-log-func comp-func)))) + (cl-loop + for i from 1 + while (comp-propagate*) + finally (comp-log (format "Propagation run %d times\n" i))) + (when (> comp-verbose 2) + (comp-log-func comp-func)))) (comp-ctxt-funcs-h comp-ctxt))) commit eca71dd5c7a8b7013eb20e1457eddf62776e6c29 Author: Andrea Corallo Date: Sat Nov 9 15:46:44 2019 +0100 fix ref propagation diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 813c826501..3d45254345 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1491,7 +1491,7 @@ This can run just once." ;; Reference propagation. (let ((operands (cons lval rest))) (when (cl-some #'comp-mvar-ref operands) - (mapc (lambda (x) (setf (comp-mvar-ref x) t)) rest)))))) + (mapc (lambda (x) (setf (comp-mvar-ref x) t)) operands)))))) (defun comp-propagate* () "Propagate for set and phi operands." commit 6761e69a2bce255bbd78e08b5c592f4de19253f5 Author: Andrea Corallo Date: Sat Nov 9 11:43:16 2019 +0100 fix missing byte-save-restriction op diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 2afbae5626..813c826501 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -932,7 +932,7 @@ the annotation emission." (comp-emit (comp-call 'record_unwind_protect_excursion))) (byte-save-window-excursion-OBSOLETE) (byte-save-restriction - (comp-call 'helper-save-restriction)) + (comp-emit (comp-call 'helper_save_restriction))) (byte-catch) ;; Obsolete (byte-unwind-protect (comp-emit (comp-call 'helper_unwind_protect (comp-slot+1)))) diff --git a/src/comp.c b/src/comp.c index 1aa0636c5b..4afba1183f 100644 --- a/src/comp.c +++ b/src/comp.c @@ -183,6 +183,7 @@ Lisp_Object helper_save_window_excursion (Lisp_Object v1); void helper_unwind_protect (Lisp_Object handler); Lisp_Object helper_temp_output_buffer_setup (Lisp_Object x); Lisp_Object helper_unbind_n (Lisp_Object n); +void helper_save_restriction (void); bool helper_PSEUDOVECTOR_TYPEP_XUNTAG (Lisp_Object a, enum pvec_type code); @@ -1695,6 +1696,8 @@ declare_runtime_imported_funcs (void) args[0] = comp.lisp_obj_type; ADD_IMPORTED ("helper_unbind_n", comp.lisp_obj_type, 1, args); + ADD_IMPORTED ("helper_save_restriction", comp.void_type, 0, NULL); + ADD_IMPORTED ("record_unwind_current_buffer", comp.void_type, 0, NULL); args[0] = args[1] = args[2] = comp.lisp_obj_type; @@ -3109,6 +3112,13 @@ helper_unbind_n (Lisp_Object n) return unbind_to (SPECPDL_INDEX () - XFIXNUM (n), Qnil); } +void +helper_save_restriction (void) +{ + record_unwind_protect (save_restriction_restore, + save_restriction_save ()); +} + bool helper_PSEUDOVECTOR_TYPEP_XUNTAG (Lisp_Object a, enum pvec_type code) { @@ -3194,6 +3204,9 @@ load_comp_unit (dynlib_handle_ptr handle) } else if (!strcmp (f_str, "helper_unbind_n")) { f_relocs[i] = (void *) helper_unbind_n; + } else if (!strcmp (f_str, "helper_save_restriction")) + { + f_relocs[i] = (void *) helper_save_restriction; } else if (!strcmp (f_str, "record_unwind_current_buffer")) { f_relocs[i] = (void *) record_unwind_current_buffer; commit 93aeb781e1da3cab6ae90c90cd3668862155ab85 Author: Andrea Corallo Date: Thu Nov 7 21:40:51 2019 +0100 fix ref ssa propagation diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index b5e9dfb384..2afbae5626 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1489,7 +1489,9 @@ This can run just once." (when (cl-reduce #'eq (mapcar #'comp-mvar-type rest)) (setf (comp-mvar-type lval) (comp-mvar-type (car rest)))) ;; Reference propagation. - (setf (comp-mvar-ref lval) (cl-every #'comp-mvar-ref rest))))) + (let ((operands (cons lval rest))) + (when (cl-some #'comp-mvar-ref operands) + (mapc (lambda (x) (setf (comp-mvar-ref x) t)) rest)))))) (defun comp-propagate* () "Propagate for set and phi operands." commit f97c03ebca440229ff953baee9e458a3ddcdaa70 Author: Andrea Corallo Date: Thu Nov 7 21:27:05 2019 +0100 add comp-tests-string-trim diff --git a/test/src/comp-test-funcs.el b/test/src/comp-test-funcs.el index e3fc0f26b5..6127d24e65 100644 --- a/test/src/comp-test-funcs.el +++ b/test/src/comp-test-funcs.el @@ -238,6 +238,9 @@ (defmacro comp-tests-macro-m (x) x) +(defun comp-tests-string-trim-f (url) + (string-trim url)) + ;;;;;;;;;;;;;;;;;;;; ;; Tromey's tests ;; ;;;;;;;;;;;;;;;;;;;; diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 9e0ca19687..6d714656ad 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -278,6 +278,9 @@ "Just check we can define macros" (should (macrop (symbol-function 'comp-tests-macro-m)))) +(ert-deftest comp-tests-string-trim () + (should (string= (comp-tests-string-trim-f "dsaf ") "dsaf"))) + ;;;;;;;;;;;;;;;;;;;; ;; Tromey's tests ;; ;;;;;;;;;;;;;;;;;;;; commit 33d8b736b0330f51050ca1fc389527d708b1eb23 Author: Andrea Corallo Date: Tue Nov 5 20:34:12 2019 +0100 do not native compile interactive functions diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 836377b4df..04c80c1757 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -2713,7 +2713,10 @@ not to take responsibility for the actual compilation of the code." (push (if macro (make-byte-to-native-top-level :form `(defalias ',name '(macro . ,code) nil)) - (make-byte-to-native-function :name name :data code)) + (if (commandp code) + (make-byte-to-native-top-level ;FIXME compile interactive functions. + :form `(defalias ',name ,code)) + (make-byte-to-native-function :name name :data code))) byte-to-native-top-level-forms)) ;; Output the form by hand, that's much simpler than having ;; b-c-output-file-form analyze the defalias. commit d392276b63cd0d9eb16f0e624bd8da9737cc66cb Author: Andrea Corallo Date: Tue Nov 5 20:47:34 2019 +0100 allow nested loadings diff --git a/src/comp.c b/src/comp.c index ba56cc1ab1..1aa0636c5b 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3123,7 +3123,7 @@ helper_PSEUDOVECTOR_TYPEP_XUNTAG (Lisp_Object a, enum pvec_type code) /**************************************/ static Lisp_Object Vnative_elisp_refs_hash; -dynlib_handle_ptr load_handle; +static Lisp_Object load_handle_stack; static void prevent_gc (Lisp_Object obj) @@ -3147,9 +3147,9 @@ static int load_comp_unit (dynlib_handle_ptr handle) { /* Imported data. */ - Lisp_Object *data_relocs = dynlib_sym (load_handle, DATA_RELOC_SYM); + Lisp_Object *data_relocs = dynlib_sym (handle, DATA_RELOC_SYM); - Lisp_Object d_vec = load_static_obj (load_handle, TEXT_DATA_RELOC_SYM); + Lisp_Object d_vec = load_static_obj (handle, TEXT_DATA_RELOC_SYM); EMACS_UINT d_vec_len = XFIXNUM (Flength (d_vec)); for (EMACS_UINT i = 0; i < d_vec_len; i++) @@ -3160,9 +3160,9 @@ load_comp_unit (dynlib_handle_ptr handle) /* Imported functions. */ Lisp_Object (**f_relocs)(void) = - dynlib_sym (load_handle, IMPORTED_FUNC_RELOC_SYM); + dynlib_sym (handle, IMPORTED_FUNC_RELOC_SYM); Lisp_Object f_vec = - load_static_obj (load_handle, TEXT_IMPORTED_FUNC_RELOC_SYM); + load_static_obj (handle, TEXT_IMPORTED_FUNC_RELOC_SYM); EMACS_UINT f_vec_len = XFIXNUM (Flength (f_vec)); for (EMACS_UINT i = 0; i < f_vec_len; i++) { @@ -3213,7 +3213,7 @@ load_comp_unit (dynlib_handle_ptr handle) } /* Executing this will perform all the expected environment modification. */ - void (*top_level_run)(void) = dynlib_sym (load_handle, "top_level_run"); + void (*top_level_run)(void) = dynlib_sym (handle, "top_level_run"); top_level_run (); return 0; @@ -3227,10 +3227,11 @@ DEFUN ("comp--register-subr", Fcomp__register_subr, (Lisp_Object name, Lisp_Object minarg, Lisp_Object maxarg, Lisp_Object c_name, Lisp_Object doc) { - if (!load_handle) + dynlib_handle_ptr handle = xmint_pointer (XCAR (load_handle_stack)); + if (!handle) error ("comp--register-subr can only be called during native code load phase."); - void *func = dynlib_sym (load_handle, SSDATA (c_name)); + void *func = dynlib_sym (handle, SSDATA (c_name)); eassert (func); union Aligned_Lisp_Subr *x = xmalloc (sizeof (union Aligned_Lisp_Subr)); @@ -3251,17 +3252,17 @@ DEFUN ("native-elisp-load", Fnative_elisp_load, Snative_elisp_load, 1, 1, 0, (Lisp_Object file) { CHECK_STRING (file); - load_handle = dynlib_open (SSDATA (file)); - if (!load_handle) + dynlib_handle_ptr handle = dynlib_open (SSDATA (file)); + load_handle_stack = Fcons (make_mint_ptr (handle), load_handle_stack); + if (!handle) xsignal2 (Qcomp_unit_open_failed, file, build_string (dynlib_error ())); - int r = load_comp_unit (load_handle); - - load_handle = NULL; - + int r = load_comp_unit (handle); if (r != 0) xsignal2 (Qcomp_unit_init_failed, file, INT_TO_INTEGER (r)); + load_handle_stack = XCDR (load_handle_stack); + return Qt; } @@ -3269,12 +3270,6 @@ DEFUN ("native-elisp-load", Fnative_elisp_load, Snative_elisp_load, 1, 1, 0, void syms_of_comp (void) { - staticpro (&Vnative_elisp_refs_hash); - Vnative_elisp_refs_hash - = make_hash_table (hashtest_eq, DEFAULT_HASH_SIZE, - DEFAULT_REHASH_SIZE, DEFAULT_REHASH_THRESHOLD, - Qnil, false); - /* Limple instruction set. */ DEFSYM (Qcomment, "comment"); DEFSYM (Qjump, "jump"); @@ -3345,8 +3340,16 @@ syms_of_comp (void) doc: /* The compiler context. */); Vcomp_ctxt = Qnil; - comp_speed = DEFAULT_SPEED; + + /* Load mechanism. */ + staticpro (&Vnative_elisp_refs_hash); + Vnative_elisp_refs_hash + = make_hash_table (hashtest_eq, DEFAULT_HASH_SIZE, + DEFAULT_REHASH_SIZE, DEFAULT_REHASH_THRESHOLD, + Qnil, false); + staticpro (&load_handle_stack); + load_handle_stack = Qnil; } #endif /* HAVE_NATIVE_COMP */ commit 9f15b4c3ca98e6af3dfe61f70d0043ae896167ac Author: Andrea Corallo Date: Mon Nov 4 23:38:37 2019 +0100 fix top level macro generation diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index a4bdbacf76..836377b4df 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -2712,7 +2712,7 @@ not to take responsibility for the actual compilation of the code." ;; Spill output for the native compiler here. (push (if macro (make-byte-to-native-top-level - :form `(defalias ,name (macro . ,code) nil)) + :form `(defalias ',name '(macro . ,code) nil)) (make-byte-to-native-function :name name :data code)) byte-to-native-top-level-forms)) ;; Output the form by hand, that's much simpler than having commit 9ee6b685a338cd06d4b053e39f3e2da505d20612 Author: Andrea Corallo Date: Mon Nov 4 23:13:23 2019 +0100 add test for macro definition diff --git a/test/src/comp-test-funcs.el b/test/src/comp-test-funcs.el index 79a25511fa..e3fc0f26b5 100644 --- a/test/src/comp-test-funcs.el +++ b/test/src/comp-test-funcs.el @@ -235,6 +235,9 @@ (t (+ (comp-tests-fib-f (- n 1)) (comp-tests-fib-f (- n 2)))))) +(defmacro comp-tests-macro-m (x) + x) + ;;;;;;;;;;;;;;;;;;;; ;; Tromey's tests ;; ;;;;;;;;;;;;;;;;;;;; diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 6eada52541..9e0ca19687 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -274,6 +274,10 @@ (ert-deftest comp-tests-recursive () (should (= (comp-tests-fib-f 10) 55))) +(ert-deftest comp-tests-macro () + "Just check we can define macros" + (should (macrop (symbol-function 'comp-tests-macro-m)))) + ;;;;;;;;;;;;;;;;;;;; ;; Tromey's tests ;; ;;;;;;;;;;;;;;;;;;;; commit 809bd5aa34727151bdf40230e2fbc3151760466b Author: Andrea Corallo Date: Mon Nov 4 23:06:54 2019 +0100 test provide diff --git a/test/src/comp-test-funcs.el b/test/src/comp-test-funcs.el index 66ce0e70e8..79a25511fa 100644 --- a/test/src/comp-test-funcs.el +++ b/test/src/comp-test-funcs.el @@ -365,4 +365,6 @@ (?< 1) (?> 2)))) +(provide 'comp-test-funcs) + ;;; comp-test-funcs.el ends here diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 06a1ae9054..6eada52541 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -36,8 +36,11 @@ "comp-test-funcs.el")) (message "Compiling %s" comp-test-src) -(native-compile comp-test-src) -(load (concat comp-test-src "n")) +(load (native-compile comp-test-src)) + +(ert-deftest comp-tests-provide () + "Testing top level provide." + (should (featurep 'comp-test-funcs))) (ert-deftest comp-tests-varref () "Testing varref." commit a2ed435e3aa18c0e6d4997cbb9a81426c952a622 Author: Andrea Corallo Date: Mon Nov 4 22:13:20 2019 +0100 fix function top_level_run generation diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 381d72e3dc..b5e9dfb384 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1047,14 +1047,10 @@ the annotation emission." (make-comp-mvar :constant doc))))) (cl-defmethod comp-emit-for-top-level ((form byte-to-native-top-level)) - (let* ((form (byte-to-native-top-level-form form)) - (func-name (car form)) - (args (cdr form))) - (if (eq 'unevalled (cdr (subr-arity (symbol-function func-name)))) - (comp-emit (comp-call func-name (make-comp-mvar :constant args))) - (comp-emit (apply #'comp-call func-name - (mapcar (lambda (x) (make-comp-mvar :constant x)) - args)))))) + (let ((form (byte-to-native-top-level-form form))) + (comp-emit (comp-call 'eval + (make-comp-mvar :constant form) + (make-comp-mvar :constant t))))) (defun comp-limplify-top-level () "Create a limple function doing the business for top level forms. commit 5c188552341204daf53f0ae2aa4e0c73ec4feb1e Author: Andrea Corallo Date: Sun Nov 3 15:27:57 2019 +0100 rework top level environment modification mechanism diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index a56b22225a..381d72e3dc 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -118,8 +118,6 @@ Can be used by code that wants to expand differently in this case.") :documentation "Target output filename for the compilation.") (top-level-forms () :type list :documentation "List of spilled top level forms.") - (exp-funcs () :type list - :documentation "Exported functions list.") (funcs-h (make-hash-table) :type hash-table :documentation "lisp-func-name -> comp-func. This is to build the prev field.") @@ -1029,6 +1027,35 @@ the annotation emission." (comp-log-func func)) func) +(cl-defgeneric comp-emit-for-top-level (form) + "Emit the limple code for top level FORM.") + +(cl-defmethod comp-emit-for-top-level ((form byte-to-native-function)) + (let* ((name (byte-to-native-function-name form)) + (f (gethash name (comp-ctxt-funcs-h comp-ctxt))) + (args (comp-func-args f)) + (c-name (comp-func-c-func-name f)) + (doc (comp-func-doc f))) + (cl-assert (and name f)) + (comp-emit (comp-call 'comp--register-subr + (make-comp-mvar :constant name) + (make-comp-mvar :constant (comp-args-base-min args)) + (make-comp-mvar :constant (if (comp-args-p args) + (comp-args-max args) + 'many)) + (make-comp-mvar :constant c-name) + (make-comp-mvar :constant doc))))) + +(cl-defmethod comp-emit-for-top-level ((form byte-to-native-top-level)) + (let* ((form (byte-to-native-top-level-form form)) + (func-name (car form)) + (args (cdr form))) + (if (eq 'unevalled (cdr (subr-arity (symbol-function func-name)))) + (comp-emit (comp-call func-name (make-comp-mvar :constant args))) + (comp-emit (apply #'comp-call func-name + (mapcar (lambda (x) (make-comp-mvar :constant x)) + args)))))) + (defun comp-limplify-top-level () "Create a limple function doing the business for top level forms. This will be called at load-time." @@ -1042,9 +1069,8 @@ This will be called at load-time." :frame (comp-new-frame 0)))) (comp-make-curr-block 'entry (comp-sp)) (comp-emit-annotation "Top level") - (cl-loop for args in (comp-ctxt-top-level-defvars comp-ctxt) - do (comp-emit (comp-call 'defvar (make-comp-mvar :constant args)))) - (comp-emit `(return ,(make-comp-mvar :constant nil))) + (mapc #'comp-emit-for-top-level (comp-ctxt-top-level-forms comp-ctxt)) + (comp-emit `(return ,(make-comp-mvar :constant t))) (comp-limplify-finalize-function func))) (defun comp-addr-to-bb-name (addr) @@ -1659,19 +1685,6 @@ These are substituted with normals 'set'." Prepare every function for final compilation and drive the C back-end." (cl-assert (= (length (comp-ctxt-data-relocs-l comp-ctxt)) (hash-table-count (comp-ctxt-data-relocs-idx comp-ctxt)))) - (setf (comp-ctxt-exp-funcs comp-ctxt) - (cl-loop with h = (comp-ctxt-funcs-h comp-ctxt) - for f being each hash-value of h - for args = (comp-func-args f) - for doc = (when (> (length (comp-func-byte-func f)) 4) - (aref (comp-func-byte-func f) 4)) - collect (vector (comp-func-symbol-name f) - (comp-func-c-func-name f) - (cons (comp-args-base-min args) - (if (comp-args-p args) - (comp-args-max args) - 'many)) - doc))) (comp--compile-ctxt-to-file name)) (defun comp-final (_) diff --git a/src/comp.c b/src/comp.c index fed599dc51..ba56cc1ab1 100644 --- a/src/comp.c +++ b/src/comp.c @@ -41,7 +41,6 @@ along with GNU Emacs. If not, see . */ #define DATA_RELOC_SYM "d_reloc" #define IMPORTED_FUNC_RELOC_SYM "f_reloc" #define TEXT_DATA_RELOC_SYM "text_data_reloc" -#define TEXT_EXPORTED_FUNC_RELOC_SYM "text_exported_funcs" #define TEXT_IMPORTED_FUNC_RELOC_SYM "text_imported_funcs" #define STR_VALUE(s) #s @@ -1802,9 +1801,6 @@ emit_ctxt_code (void) gcc_jit_struct_as_type (f_reloc_struct), IMPORTED_FUNC_RELOC_SYM); - /* Exported functions info. */ - Lisp_Object func_list = FUNCALL1 (comp-ctxt-exp-funcs, Vcomp_ctxt); - emit_static_object (TEXT_EXPORTED_FUNC_RELOC_SYM, func_list); SAFE_FREE (); } @@ -3127,6 +3123,7 @@ helper_PSEUDOVECTOR_TYPEP_XUNTAG (Lisp_Object a, enum pvec_type code) /**************************************/ static Lisp_Object Vnative_elisp_refs_hash; +dynlib_handle_ptr load_handle; static void prevent_gc (Lisp_Object obj) @@ -3150,9 +3147,9 @@ static int load_comp_unit (dynlib_handle_ptr handle) { /* Imported data. */ - Lisp_Object *data_relocs = dynlib_sym (handle, DATA_RELOC_SYM); + Lisp_Object *data_relocs = dynlib_sym (load_handle, DATA_RELOC_SYM); - Lisp_Object d_vec = load_static_obj (handle, TEXT_DATA_RELOC_SYM); + Lisp_Object d_vec = load_static_obj (load_handle, TEXT_DATA_RELOC_SYM); EMACS_UINT d_vec_len = XFIXNUM (Flength (d_vec)); for (EMACS_UINT i = 0; i < d_vec_len; i++) @@ -3163,11 +3160,11 @@ load_comp_unit (dynlib_handle_ptr handle) /* Imported functions. */ Lisp_Object (**f_relocs)(void) = - dynlib_sym (handle, IMPORTED_FUNC_RELOC_SYM); + dynlib_sym (load_handle, IMPORTED_FUNC_RELOC_SYM); Lisp_Object f_vec = - load_static_obj (handle, TEXT_IMPORTED_FUNC_RELOC_SYM); + load_static_obj (load_handle, TEXT_IMPORTED_FUNC_RELOC_SYM); EMACS_UINT f_vec_len = XFIXNUM (Flength (f_vec)); - for (EMACS_UINT i = 0; i < f_vec_len; i++) + for (EMACS_UINT i = 0; i < f_vec_len; i++) { Lisp_Object f_sym = AREF (f_vec, i); char *f_str = SSDATA (SYMBOL_NAME (f_sym)); @@ -3215,53 +3212,52 @@ load_comp_unit (dynlib_handle_ptr handle) } } - /* Exported functions. */ - Lisp_Object func_list = load_static_obj (handle, TEXT_EXPORTED_FUNC_RELOC_SYM); - - while (func_list) - { - Lisp_Object el = XCAR (func_list); - Lisp_Object Qsym = AREF (el, 0); - char *c_func_name = SSDATA (AREF (el, 1)); - Lisp_Object args = AREF (el, 2); - ptrdiff_t minargs = XFIXNUM (XCAR (args)); - ptrdiff_t maxargs = FIXNUMP (XCDR (args)) ? XFIXNUM (XCDR (args)) : MANY; - /* char *doc = SSDATA (AREF (el, 3)); */ - void *func = dynlib_sym (handle, c_func_name); - eassert (func); - - union Aligned_Lisp_Subr *x = xmalloc (sizeof (union Aligned_Lisp_Subr)); - x->s.header.size = PVEC_SUBR << PSEUDOVECTOR_AREA_BITS; - x->s.function.a0 = func; - x->s.min_args = minargs; - x->s.max_args = maxargs; - x->s.symbol_name = SSDATA (Fsymbol_name (Qsym)); - x->s.native_elisp = true; - defsubr(x); - - func_list = XCDR (func_list); - } - - /* Finally execute top level forms. */ - void (*top_level_run)(void) = dynlib_sym (handle, "top_level_run"); + /* Executing this will perform all the expected environment modification. */ + void (*top_level_run)(void) = dynlib_sym (load_handle, "top_level_run"); top_level_run (); return 0; } +DEFUN ("comp--register-subr", Fcomp__register_subr, + Scomp__register_subr, + 5, 5, 0, + doc: /* This gets called by top_level_run during load phase to register + each exported subr. */) + (Lisp_Object name, Lisp_Object minarg, Lisp_Object maxarg, + Lisp_Object c_name, Lisp_Object doc) +{ + if (!load_handle) + error ("comp--register-subr can only be called during native code load phase."); + + void *func = dynlib_sym (load_handle, SSDATA (c_name)); + eassert (func); + + union Aligned_Lisp_Subr *x = xmalloc (sizeof (union Aligned_Lisp_Subr)); + x->s.header.size = PVEC_SUBR << PSEUDOVECTOR_AREA_BITS; + x->s.function.a0 = func; + x->s.min_args = XFIXNUM (minarg); + x->s.max_args = FIXNUMP (maxarg) ? XFIXNUM (maxarg) : MANY; + x->s.symbol_name = SSDATA (Fsymbol_name (name)); + x->s.native_elisp = true; + defsubr(x); + + return Qnil; +} + /* Load related routines. */ DEFUN ("native-elisp-load", Fnative_elisp_load, Snative_elisp_load, 1, 1, 0, doc: /* Load native elisp code FILE. */) (Lisp_Object file) { - dynlib_handle_ptr handle; - CHECK_STRING (file); - handle = dynlib_open (SSDATA (file)); - if (!handle) + load_handle = dynlib_open (SSDATA (file)); + if (!load_handle) xsignal2 (Qcomp_unit_open_failed, file, build_string (dynlib_error ())); - int r = load_comp_unit (handle); + int r = load_comp_unit (load_handle); + + load_handle = NULL; if (r != 0) xsignal2 (Qcomp_unit_init_failed, file, INT_TO_INTEGER (r)); @@ -3332,6 +3328,7 @@ syms_of_comp (void) defsubr (&Scomp__init_ctxt); defsubr (&Scomp__release_ctxt); defsubr (&Scomp__compile_ctxt_to_file); + defsubr (&Scomp__register_subr); defsubr (&Snative_elisp_load); staticpro (&comp.exported_funcs_h); commit bf91dd23fb7dd37650dfdb218358c8bac659c5a6 Author: Andrea Corallo Date: Sat Nov 2 17:34:32 2019 +0100 rework comp-spill-lap-functions-file diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 8a9305a59b..a56b22225a 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -384,53 +384,57 @@ Put PREFIX in front of it." ;; For the 1+ see bytecode.c:365 (finger crossed). (1+ (aref byte-compiled-func 3))) -(defun comp-spill-lap-function (function-name) +(defun comp-spill-lap-function (_function-name) "Byte compile FUNCTION-NAME spilling data from the byte compiler." - (let* ((f (symbol-function function-name)) - (func (make-comp-func :symbol-name function-name - :c-func-name (comp-c-func-name - function-name - "F")))) - (when (byte-code-function-p f) - (error "Can't native compile an already bytecompiled function")) - (setf (comp-func-byte-func func) - (byte-compile (comp-func-symbol-name func))) - (let ((lap (alist-get function-name (reverse byte-to-native-bytecode)))) - (cl-assert lap) - (comp-log lap) - (let ((lambda-list (aref (comp-func-byte-func func) 0))) - (setf (comp-func-args func) - (comp-decrypt-lambda-list lambda-list))) - (setf (comp-func-lap func) lap) - (setf (comp-func-frame-size func) - (comp-byte-frame-size (comp-func-byte-func func))) - func))) + (error "To be reimplemented") + ;; (let* ((f (symbol-function function-name)) + ;; (func (make-comp-func :symbol-name function-name + ;; :c-func-name (comp-c-func-name + ;; function-name + ;; "F")))) + ;; (when (byte-code-function-p f) + ;; (error "Can't native compile an already bytecompiled function")) + ;; (setf (comp-func-byte-func func) + ;; (byte-compile (comp-func-symbol-name func))) + ;; (let ((lap (alist-get function-name (reverse byte-to-native-bytecode)))) + ;; (cl-assert lap) + ;; (comp-log lap) + ;; (let ((lambda-list (aref (comp-func-byte-func func) 0))) + ;; (setf (comp-func-args func) + ;; (comp-decrypt-lambda-list lambda-list))) + ;; (setf (comp-func-lap func) lap) + ;; (setf (comp-func-frame-size func) + ;; (comp-byte-frame-size (comp-func-byte-func func))) + ;; func)) + ) (defun comp-spill-lap-functions-file (filename) "Byte compile FILENAME spilling data from the byte compiler." (byte-compile-file filename) - (setf (comp-ctxt-top-level-defvars comp-ctxt) - (reverse (mapcar (lambda (x) - (cl-ecase (car x) - ('defvar (cdr x)) - ('defconst (cdr x)))) - byte-to-native-top-level-forms))) - (cl-loop for (name . bytecode) in byte-to-native-bytecode - for lap = (alist-get name byte-to-native-lap) - for lambda-list = (aref bytecode 0) - for func = (make-comp-func :symbol-name name - :byte-func bytecode - :c-func-name (comp-c-func-name - name - "F") - :args (comp-decrypt-lambda-list lambda-list) - :lap lap - :frame-size (comp-byte-frame-size - bytecode)) - do (when (> comp-verbose 1) - (comp-log (format "Function %s:\n" name)) - (comp-log lap)) - collect func)) + (setf (comp-ctxt-top-level-forms comp-ctxt) (reverse byte-to-native-top-level-forms)) + (cl-loop + for f in (cl-loop for x in byte-to-native-top-level-forms ; All non anonymous. + when (and (byte-to-native-function-p x) + (byte-to-native-function-name x)) + collect x) + for name = (byte-to-native-function-name f) + for data = (byte-to-native-function-data f) + for doc = (when (>= (length data) 5) (aref data 4)) + for lap = (alist-get name byte-to-native-lap) + for lambda-list = (aref data 0) + for func = (make-comp-func :symbol-name name + :byte-func data + :doc doc + :c-func-name (comp-c-func-name + name + "F") + :args (comp-decrypt-lambda-list lambda-list) + :lap lap + :frame-size (comp-byte-frame-size data)) + when (> comp-verbose 1) + do (comp-log (format "Function %s:\n" name)) + (comp-log lap) + collect func)) (defun comp-spill-lap (input) "Byte compile and spill the LAP rapresentation for INPUT. commit 03d2dda12f9e5d877edd15e31d6076361ccbd75a Author: Andrea Corallo Date: Sat Nov 2 17:33:55 2019 +0100 add doc slot into comp-func struct diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index c52cef6e94..8a9305a59b 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -205,6 +205,8 @@ Is in use to help the SSA rename pass.")) :documentation "The function name in the native world.") (byte-func nil :documentation "Byte compiled version.") + (doc nil :type string + :documentation "Doc string.") (lap () :type list :documentation "LAP assembly representation.") (args nil :type comp-args-base) commit fb41165adf7c6a354876a26fd7a6cc686f3fe142 Author: Andrea Corallo Date: Sat Nov 2 17:32:42 2019 +0100 add top-level-forms slot into comp-ctxt (replace old specific defvar one) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index e76e68c31b..c52cef6e94 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -116,8 +116,8 @@ Can be used by code that wants to expand differently in this case.") "Lisp side of the compiler context." (output nil :type string :documentation "Target output filename for the compilation.") - (top-level-defvars nil :type list - :documentation "List of top level form to be exp.") + (top-level-forms () :type list + :documentation "List of spilled top level forms.") (exp-funcs () :type list :documentation "Exported functions list.") (funcs-h (make-hash-table) :type hash-table commit fb309c14f0f5075cd649c083abf2a0713b949030 Author: Andrea Corallo Date: Sat Nov 2 17:32:20 2019 +0100 limplify top level at last diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 89744f6e0d..e76e68c31b 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1123,9 +1123,8 @@ This will be called at load-time." (defun comp-limplify (lap-funcs) "Compute the LIMPLE ir for LAP-FUNCS. Top level forms for the current context are rendered too." - (mapc #'comp-add-func-to-ctxt - (cons (comp-limplify-top-level) - (mapcar #'comp-limplify-function lap-funcs)))) + (mapc #'comp-add-func-to-ctxt (mapcar #'comp-limplify-function lap-funcs)) + (comp-add-func-to-ctxt (comp-limplify-top-level))) ;;; SSA pass specific code. commit 5eb8d3dba14d94386f42dbb8fcdd28a98d10ac64 Author: Andrea Corallo Date: Sat Nov 2 16:48:40 2019 +0100 rework bytecomp spill code diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 72e5835020..a4bdbacf76 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -564,14 +564,19 @@ Each element is (INDEX . VALUE)") (defvar byte-compile-maxdepth 0 "Maximum depth of execution stack.") ;; These are use by comp.el to spill data out of here -(defvar byte-native-compiling nil) +(cl-defstruct byte-to-native-function + "Named or anonymous function defined a top level." + name data) +(cl-defstruct byte-to-native-top-level + "All other top level forms." + form) +(defvar byte-native-compiling nil + "t while native compiling.") (defvar byte-to-native-lap nil - "Alist to accumulate lap. -Each element is (NAME . LAP)") -(defvar byte-to-native-bytecode nil - "Alist to accumulate bytecode. -Each element is (NAME . BYTECODE)") -(defvar byte-to-native-top-level-forms nil) + "A-list to accumulate LAP. +Each pair is (NAME . LAP)") +(defvar byte-to-native-top-level-forms nil + "List of top level forms.") ;;; The byte codes; this information is duplicated in bytecomp.c @@ -2245,6 +2250,10 @@ Call from the source buffer." ;; defalias calls are output directly by byte-compile-file-form-defmumble; ;; it does not pay to first build the defalias in defmumble and then parse ;; it here. + (when byte-native-compiling + ;; Spill output for the native compiler here + (push (make-byte-to-native-top-level :form form) + byte-to-native-top-level-forms)) (let ((print-escape-newlines t) (print-length nil) (print-level nil) @@ -2276,10 +2285,6 @@ we output that argument and the following argument QUOTED says that we have to put a quote before the list that represents a doc string reference. `defvaralias', `autoload' and `custom-declare-variable' need that." - (when (and byte-native-compiling name) - ;; Spill bytecode output for the native compiler here - (push (cons name (apply #'vector form)) - byte-to-native-bytecode)) ;; We need to examine byte-compile-dynamic-docstrings ;; in the input buffer (now current), not in the output buffer. (let ((dynamic-docstrings byte-compile-dynamic-docstrings)) @@ -2496,9 +2501,6 @@ list that represents a doc string reference. (setq form (copy-sequence form)) (setcar (cdr (cdr form)) (byte-compile-top-level (nth 2 form) nil 'file)))) - (when byte-native-compiling - ;; Spill output for the native compiler here - (push form byte-to-native-top-level-forms)) form)) (put 'define-abbrev-table 'byte-hunk-handler @@ -2706,6 +2708,13 @@ not to take responsibility for the actual compilation of the code." ;; If there's no doc string, provide -1 as the "doc string ;; index" so that no element will be treated as a doc string. (if (not (stringp (documentation code t))) -1 4))) + (when byte-native-compiling + ;; Spill output for the native compiler here. + (push (if macro + (make-byte-to-native-top-level + :form `(defalias ,name (macro . ,code) nil)) + (make-byte-to-native-function :name name :data code)) + byte-to-native-top-level-forms)) ;; Output the form by hand, that's much simpler than having ;; b-c-output-file-form analyze the defalias. (byte-compile-output-docform commit d6ae5369b0682ada2e7d801a3cc54f671ed03bf3 Author: Andrea Corallo Date: Sat Nov 2 14:34:31 2019 +0100 some code massage diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 4fb9c129a8..89744f6e0d 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -556,7 +556,7 @@ The basic block is returned regardless it was already declared or not." (make-comp-ssa-mvar :slot i) (make-comp-mvar :slot i)) do (aset v i mvar) - finally (return v))) + finally return v)) (defsubst comp-emit (insn) "Emit INSN into basic block BB." @@ -1051,7 +1051,7 @@ This will be called at load-time." (comp-block-name pending) (cl-loop for bb being the hash-value in (comp-func-blocks comp-func) when (pred bb) - do (return (comp-block-name bb)))))) + return (comp-block-name bb))))) (defun comp-limplify-block (bb) "Limplify basic-block BB and add it to the current function." @@ -1285,7 +1285,7 @@ Top level forms for the current context are rendered too." (cl-loop for insn in (comp-block-insns bb) when (and (comp-assign-op-p (car insn)) (= slot-n (comp-mvar-slot (cadr insn)))) - return t))) + return t))) (cl-loop for i from 0 below (comp-func-frame-size comp-func) ;; List of blocks with a definition of mvar i commit 0720354082858f59db9f70ada33efc424126d668 Author: Andrea Corallo Date: Sat Nov 2 12:34:09 2019 +0100 native compile return the filename of the compilation unit diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 2f6bcf71b1..4fb9c129a8 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1702,7 +1702,8 @@ Prepare every function for final compilation and drive the C back-end." "Compile INPUT into native code. This is the entrypoint 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." +If INPUT is a string, use it as the file path to be native compiled. +Return the compilation unit filename." (unless (or (symbolp input) (stringp input)) (error "Trying to native compile something not a symbol function or file")) @@ -1716,7 +1717,8 @@ If INPUT is a string, use it as the file path to be native compiled." (mapc (lambda (pass) (comp-log (format "Running pass %s:\n" pass)) (setq data (funcall pass data))) - comp-passes))) + comp-passes) + data)) (provide 'comp) diff --git a/src/comp.c b/src/comp.c index 3b124bef23..fed599dc51 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3061,16 +3061,15 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, gcc_jit_context_dump_reproducer_to_file (comp.ctxt, "comp_reproducer.c"); AUTO_STRING (dot_so, NATIVE_ELISP_SUFFIX); - const char *filename = - (const char *) SDATA (CALLN (Fconcat, ctxtname, dot_so)); + Lisp_Object out_file = CALLN (Fconcat, ctxtname, dot_so); gcc_jit_context_compile_to_file (comp.ctxt, GCC_JIT_OUTPUT_KIND_DYNAMIC_LIBRARY, - filename); + SSDATA (out_file)); pthread_sigmask (SIG_SETMASK, &oldset, 0); - return Qt; + return out_file; } commit 0f68de830acb5eef41307efc119f3f16fdb35ab3 Author: Andrea Corallo Date: Sat Nov 2 12:17:26 2019 +0100 fix limplification for functions with more than 8 args diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 49212815c8..2f6bcf71b1 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -145,7 +145,9 @@ To be used when ncall-conv is nil.")) "Describe args when the functin signature is of kind: (ptrdiff_t nargs, Lisp_Object *args)." (nonrest nil :type number - :documentation "Number of non rest arguments.")) + :documentation "Number of non rest arguments.") + (rest nil :type boolean + :documentation "t if rest argument is present.")) (cl-defstruct (comp-block (:copier nil) (:constructor make--comp-block @@ -371,7 +373,8 @@ Put PREFIX in front of it." (make-comp-args :min mandatory :max nonrest) (make-comp-nargs :min mandatory - :nonrest nonrest)))) + :nonrest nonrest + :rest rest)))) (defun comp-byte-frame-size (byte-compiled-func) "Given BYTE-COMPILED-FUNC return the frame size to be allocated." @@ -982,7 +985,7 @@ the annotation emission." (cl-incf (comp-sp) (- arg)) (comp-copy-slot (+ arg (comp-sp))))))) -(defun comp-emit-narg-prologue (minarg nonrest) +(defun comp-emit-narg-prologue (minarg nonrest rest) "Emit the prologue for a narg function." (cl-loop for i below minarg do (comp-emit `(set-args-to-local ,(comp-slot-n i))) @@ -1006,7 +1009,10 @@ the annotation emission." (comp-emit-set-const nil) (comp-emit `(jump ,next-bb))))) (comp-make-curr-block 'entry_rest_args (comp-sp)) - (comp-emit `(set-rest-args-to-local ,(comp-slot-n nonrest)))) + (comp-emit `(set-rest-args-to-local ,(comp-slot-n nonrest))) + (setf (comp-sp) nonrest) + (when (and (> nonrest 8) (null rest)) + (cl-decf (comp-sp)))) (defun comp-limplify-finalize-function (func) "Reverse insns into all basic blocks of FUNC." @@ -1080,8 +1086,7 @@ This will be called at load-time." (comp-func func) (comp-pass (make-comp-limplify :frame (comp-new-frame frame-size))) - (args (comp-func-args func)) - (args-min (comp-args-base-min args))) + (args (comp-func-args func))) (comp-fill-label-h) ;; Prologue (comp-make-curr-block 'entry (comp-sp)) @@ -1091,9 +1096,9 @@ This will be called at load-time." (cl-loop for i below (comp-args-max args) do (cl-incf (comp-sp)) (comp-emit `(set-par-to-local ,(comp-slot) ,i))) - (let ((nonrest (comp-nargs-nonrest args))) - (comp-emit-narg-prologue args-min nonrest) - (cl-incf (comp-sp) (1+ nonrest)))) + (comp-emit-narg-prologue (comp-args-base-min args) + (comp-nargs-nonrest args) + (comp-nargs-rest args))) (comp-emit '(jump bb_0)) ;; Body (comp-bb-maybe-add 0 (comp-sp)) commit a18e54f54bdcd5d9b2c11b0307b0a157f52e5926 Author: Andrea Corallo Date: Sat Nov 2 12:16:41 2019 +0100 add a test for functions with more than 8 arguments diff --git a/test/src/comp-test-funcs.el b/test/src/comp-test-funcs.el index 540170ea96..66ce0e70e8 100644 --- a/test/src/comp-test-funcs.el +++ b/test/src/comp-test-funcs.el @@ -81,6 +81,14 @@ (defun comp-tests-ffuncall-callee-rest-f (a b &rest c) (list a b c)) +(defun comp-tests-ffuncall-callee-more8-f (p1 p2 p3 p4 p5 p6 p7 p8 p9 p10) + ;; More then 8 args. + (list p1 p2 p3 p4 p5 p6 p7 p8 p9 p10)) + +(defun comp-tests-ffuncall-callee-more8-rest-f (p1 p2 p3 p4 p5 p6 p7 p8 p9 &rest p10) + ;; More then 8 args. + (list p1 p2 p3 p4 p5 p6 p7 p8 p9 p10)) + (defun comp-tests-ffuncall-native-f () "Call a primitive with no dedicate op." (make-vector 1 nil)) @@ -342,6 +350,7 @@ (defun comp-test-callee (_ __) t) (defun comp-test-silly-frame1 (x) + ;; Check robustness against dead code. (cl-case x (0 (comp-test-callee (pcase comp-tests-var1 @@ -350,6 +359,7 @@ 3)))) (defun comp-test-silly-frame2 (token) + ;; Check robustness against dead code. (while c (cl-case c (?< 1) diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 16726cb4bb..06a1ae9054 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -124,6 +124,12 @@ (should (equal (comp-tests-ffuncall-callee-rest-f 1 2 3 4) '(1 2 (3 4)))) + (should (equal (comp-tests-ffuncall-callee-more8-f 1 2 3 4 5 6 7 8 9 10) + '(1 2 3 4 5 6 7 8 9 10))) + + (should (equal (comp-tests-ffuncall-callee-more8-rest-f 1 2 3 4 5 6 7 8 9 10 11) + '(1 2 3 4 5 6 7 8 9 (10 11)))) + (should (equal (comp-tests-ffuncall-native-f) [nil])) (should (equal (comp-tests-ffuncall-native-rest-f) [1 2 3])) commit e0e0b92c1d3fe39085731db04bacd9def31f3940 Author: Andrea Corallo Date: Fri Nov 1 15:28:17 2019 +0100 rework limplify to prevent block duplication diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index e5db273a8e..49212815c8 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -147,7 +147,9 @@ To be used when ncall-conv is nil.")) (nonrest nil :type number :documentation "Number of non rest arguments.")) -(cl-defstruct (comp-block (:copier nil) (:constructor make--comp-block)) +(cl-defstruct (comp-block (:copier nil) + (:constructor make--comp-block + (addr sp name))) ; Positional "A basic block." (name nil :type symbol) ;; These two slots are used during limplification. @@ -506,20 +508,22 @@ Restore the original value afterwards." (or (gethash label (comp-limplify-label-to-addr comp-pass)) (error "Can't find label %d" label))) -(cl-defun comp-block-maybe-mark-pending (&rest args &key name sp &allow-other-keys) - "If necessary create a pending basic block. -The basic block is returned." - (if-let ((bb (gethash name (comp-func-blocks comp-func)))) - ;; If was already declared sanity check sp. - (progn - (cl-assert (or (null sp) (= sp (comp-block-sp bb))) - (sp (comp-block-sp bb)) "sp %d %d differs") - bb) - ;; Look into the pendings and add the a new one there if necessary. - (or (cl-find-if (lambda (bb) - (eq (comp-block-name bb) name)) - (comp-limplify-pending-blocks comp-pass)) - (car (push (apply #'make--comp-block args) +(defun comp-bb-maybe-add (lap-addr &optional sp) + "If necessary create a pending basic block for LAP-ADDR with stack depth SP. +The basic block is returned regardless it was already declared or not." + (let ((bb (or (cl-loop ; See if the block was already liplified. + for bb being the hash-value in (comp-func-blocks comp-func) + when (equal (comp-block-addr bb) lap-addr) + return bb) + (cl-find-if (lambda (bb) ; Look within the pendings blocks. + (= (comp-block-addr bb) lap-addr)) + (comp-limplify-pending-blocks comp-pass))))) + (if bb + (progn + (cl-assert (or (null sp) (= sp (comp-block-sp bb))) + (sp (comp-block-sp bb)) "sp %d %d differs") + bb) + (car (push (make--comp-block lap-addr sp (comp-new-block-sym)) (comp-limplify-pending-blocks comp-pass)))))) (defun comp-call (func &rest args) @@ -591,33 +595,21 @@ If DST-N is specified use it otherwise assume it to be the current slot." ENTRY-SP is the sp value when entering. The block is added to the current function. The block is returned." - (let ((bb (make--comp-block :name block-name :sp entry-sp :addr addr))) + (let ((bb (make--comp-block addr entry-sp block-name))) (setf (comp-limplify-curr-block comp-pass) bb) (setf (comp-limplify-pc comp-pass) addr) (setf (comp-limplify-sp comp-pass) (comp-block-sp bb)) (puthash (comp-block-name bb) bb (comp-func-blocks comp-func)) bb)) -(defun comp-lap-to-limple-bb (n) - "Given the LAP label N return the limple basic block name." - (let ((hash (comp-func-lap-block comp-func))) - (if-let ((bb (gethash n hash))) - ;; If was already created return it. - bb - (let ((name (comp-new-block-sym))) - (puthash n name hash) - name)))) - (defun comp-emit-uncond-jump (lap-label) "Emit an unconditional branch to LAP-LABEL." (cl-destructuring-bind (label-num . stack-depth) lap-label (when stack-depth (cl-assert (= (1- stack-depth) (comp-sp)))) - (let ((target (comp-lap-to-limple-bb label-num))) - (comp-block-maybe-mark-pending :name target - :sp (comp-sp) - :addr (comp-label-to-addr label-num)) - (comp-emit `(jump ,target)) + (let ((target (comp-bb-maybe-add (comp-label-to-addr label-num) + (comp-sp)))) + (comp-emit `(jump ,(comp-block-name target))) (setf (comp-block-closed (comp-limplify-curr-block comp-pass)) t)))) (defun comp-emit-cond-jump (a b target-offset lap-label negated) @@ -627,17 +619,13 @@ block. If NEGATED non null negate the tested condition. Return value is the fall through block name." (cl-destructuring-bind (label-num . label-sp) lap-label - (let ((bb (comp-new-block-sym)) ; Fall through block. - (target (comp-lap-to-limple-bb label-num)) - (target-sp (+ target-offset (comp-sp)))) + (let* ((bb (comp-block-name (comp-bb-maybe-add (1+ (comp-limplify-pc comp-pass)) + (comp-sp)))) ; Fall through block. + (target-sp (+ target-offset (comp-sp))) + (target (comp-block-name (comp-bb-maybe-add (comp-label-to-addr label-num) + target-sp)))) (when label-sp (cl-assert (= (1- label-sp) (+ target-offset (comp-sp))))) - (comp-block-maybe-mark-pending :name bb - :sp (comp-sp) - :addr (1+ (comp-limplify-pc comp-pass))) - (comp-block-maybe-mark-pending :name target - :sp target-sp - :addr (comp-label-to-addr label-num)) (comp-emit (if negated (list 'cond-jump a b target bb) (list 'cond-jump a b bb target))) @@ -648,22 +636,18 @@ Return value is the fall through block name." "Emit a non local exit handler to LAP-LABEL of type HANDLER-TYPE." (cl-destructuring-bind (label-num . label-sp) lap-label (cl-assert (= (- label-sp 2) (comp-sp))) - (let* ((guarded-name (comp-new-block-sym)) - (handler-name (comp-lap-to-limple-bb label-num)) - (handler-buff-n (comp-func-handler-cnt comp-func)) - (handler-bb (comp-block-maybe-mark-pending :name handler-name - :sp (1+ (comp-sp)) - :addr - (comp-label-to-addr label-num)))) - (comp-block-maybe-mark-pending :name guarded-name - :sp (comp-sp) - :addr (1+ (comp-limplify-pc comp-pass))) + (let* ((guarded-bb (comp-bb-maybe-add (1+ (comp-limplify-pc comp-pass)) + (comp-sp))) + (handler-bb (comp-bb-maybe-add (comp-label-to-addr label-num) + (1+ (comp-sp)))) + (handler-buff-n (comp-func-handler-cnt comp-func))) + (comp-emit (list 'push-handler handler-type (comp-slot+1) handler-buff-n - handler-name - guarded-name)) + (comp-block-name handler-bb) + (comp-block-name guarded-bb))) (setf (comp-block-closed (comp-limplify-curr-block comp-pass)) t) (comp-emit-as-head `(fetch-handler ,(comp-slot+1) ,handler-buff-n) handler-bb) (cl-incf (comp-func-handler-cnt comp-func))))) @@ -697,26 +681,28 @@ Return value is the fall through block name." "Emit a limple for a lap jump table given VAR and LAST-INSN." (pcase last-insn (`(setimm ,_ ,_ ,const) - (cl-loop for test being each hash-keys of const - using (hash-value target-label) - with len = (hash-table-count const) - for n from 1 - for last = (= n len) - for m-test = (make-comp-mvar :constant test) - for ff-bb = (comp-new-block-sym) ; Fall through block. - for target = (comp-lap-to-limple-bb target-label) - do - (comp-emit (list 'cond-jump var m-test ff-bb target)) - (comp-block-maybe-mark-pending :name target - :sp (comp-sp) - :addr (comp-label-to-addr target-label)) - (if last - (comp-block-maybe-mark-pending :name ff-bb - :sp (comp-sp) - :addr (1+ (comp-limplify-pc comp-pass))) - (comp-make-curr-block ff-bb + (cl-loop + for test being each hash-keys of const + using (hash-value target-label) + with len = (hash-table-count const) + for n from 1 + for last = (= n len) + for m-test = (make-comp-mvar :constant test) + for target-name = (comp-block-name (comp-bb-maybe-add (comp-label-to-addr target-label) + (comp-sp))) + for ff-bb = (if last + (comp-bb-maybe-add (1+ (comp-limplify-pc comp-pass)) + (comp-sp)) + (make--comp-block nil (comp-sp) - (comp-limplify-pc comp-pass))))) + (comp-new-block-sym))) + for ff-bb-name = (comp-block-name ff-bb) + do + (comp-emit (list 'cond-jump var m-test ff-bb-name target-name)) + (unless last + ;; All fall through are artificially created here except the last one. + (puthash ff-bb-name ff-bb (comp-func-blocks comp-func)) + (setf (comp-limplify-curr-block comp-pass) ff-bb)))) (_ (error "Missing previous setimm while creating a switch")))) (defun comp-emit-set-call-subr (subr-name sp-delta) @@ -1040,7 +1026,7 @@ This will be called at load-time." :frame-size 0)) (comp-func func) (comp-pass (make-comp-limplify - :curr-block (make--comp-block) + :curr-block (make--comp-block -1 0 'top-level) :frame (comp-new-frame 0)))) (comp-make-curr-block 'entry (comp-sp)) (comp-emit-annotation "Top level") @@ -1061,16 +1047,6 @@ This will be called at load-time." when (pred bb) do (return (comp-block-name bb)))))) -(defun comp-add-pending-block (sp) - "Create basic block and add it to the pending queue if necessary. -The block name is returned." - (let ((next-bb (or (comp-addr-to-bb-name (comp-limplify-pc comp-pass)) - (comp-new-block-sym)))) - (comp-block-maybe-mark-pending :name next-bb - :sp sp - :addr (comp-limplify-pc comp-pass)) - next-bb)) - (defun comp-limplify-block (bb) "Limplify basic-block BB and add it to the current function." (setf (comp-limplify-curr-block comp-pass) bb) @@ -1092,7 +1068,7 @@ The block name is returned." (let* ((stack-depth (if label-sp (1- label-sp) (comp-sp))) - (next-bb (comp-add-pending-block stack-depth))) + (next-bb (comp-block-name (comp-bb-maybe-add (comp-limplify-pc comp-pass) stack-depth)))) (unless (comp-block-closed bb) (comp-emit `(jump ,next-bb)))) (cl-return))) @@ -1120,9 +1096,7 @@ The block name is returned." (cl-incf (comp-sp) (1+ nonrest)))) (comp-emit '(jump bb_0)) ;; Body - (comp-block-maybe-mark-pending :name (comp-new-block-sym) - :sp (comp-sp) - :addr 0) + (comp-bb-maybe-add 0 (comp-sp)) (cl-loop for next-bb = (pop (comp-limplify-pending-blocks comp-pass)) while next-bb do (comp-limplify-block next-bb)) @@ -1130,8 +1104,9 @@ The block name is returned." (cl-loop with addr-h = (make-hash-table) for bb being the hash-value in (comp-func-blocks func) for addr = (comp-block-addr bb) - do (cl-assert (null (gethash addr addr-h))) - (puthash addr t addr-h)) + when addr + do (cl-assert (null (gethash addr addr-h))) + (puthash addr t addr-h)) (comp-limplify-finalize-function func))) (defun comp-add-func-to-ctxt (func) commit 515644edc0ed2e73198f4c4eeb822715b2589dc9 Author: Andrea Corallo Date: Sun Oct 27 18:14:33 2019 +0100 sanity check against block duplication. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index abcddda380..e5db273a8e 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -507,7 +507,7 @@ Restore the original value afterwards." (error "Can't find label %d" label))) (cl-defun comp-block-maybe-mark-pending (&rest args &key name sp &allow-other-keys) - "Create a basic block and mark it as pending. + "If necessary create a pending basic block. The basic block is returned." (if-let ((bb (gethash name (comp-func-blocks comp-func)))) ;; If was already declared sanity check sp. @@ -1062,7 +1062,7 @@ This will be called at load-time." do (return (comp-block-name bb)))))) (defun comp-add-pending-block (sp) - "Add next basic block to the pending queue. + "Create basic block and add it to the pending queue if necessary. The block name is returned." (let ((next-bb (or (comp-addr-to-bb-name (comp-limplify-pc comp-pass)) (comp-new-block-sym)))) @@ -1126,6 +1126,12 @@ The block name is returned." (cl-loop for next-bb = (pop (comp-limplify-pending-blocks comp-pass)) while next-bb do (comp-limplify-block next-bb)) + ;; Sanity check against block duplication. + (cl-loop with addr-h = (make-hash-table) + for bb being the hash-value in (comp-func-blocks func) + for addr = (comp-block-addr bb) + do (cl-assert (null (gethash addr addr-h))) + (puthash addr t addr-h)) (comp-limplify-finalize-function func))) (defun comp-add-func-to-ctxt (func) commit 0b9bec6863e138efee77c2948c355b53951e6d18 Author: Andrea Corallo Date: Sun Oct 27 17:13:03 2019 +0100 fix comp-emit-narg-prologue diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 1891398c14..abcddda380 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1008,14 +1008,17 @@ the annotation emission." (comp-make-curr-block bb (comp-sp)) (comp-emit `(set-args-to-local ,(comp-slot-n i))) (comp-emit '(inc-args)) - finally (comp-emit '(jump entry_rest_args))) + finally (comp-emit '(jump entry_rest_args))) (when (not (= minarg nonrest)) (cl-loop for i from minarg below nonrest + for bb = (intern (format "entry_fallback_%s" i)) + for next-bb = (if (= (1+ i) nonrest) + 'entry_rest_args + (intern (format "entry_fallback_%s" (1+ i)))) do (comp-with-sp i - (comp-make-curr-block (intern (format "entry_fallback_%s" i)) - (comp-sp)) - (comp-emit-set-const nil)) - finally (comp-emit '(jump entry_rest_args)))) + (comp-make-curr-block bb (comp-sp)) + (comp-emit-set-const nil) + (comp-emit `(jump ,next-bb))))) (comp-make-curr-block 'entry_rest_args (comp-sp)) (comp-emit `(set-rest-args-to-local ,(comp-slot-n nonrest)))) commit 283b0db31c87a8bed736a8459ab16ae066ceb024 Author: Andrea Corallo Date: Sun Oct 27 16:57:29 2019 +0100 Revert "simplify comp-limplify-block" This reverts commit 31861f63a4b57e69cdcd247e48567242a05bd58e. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 7b77b4d87c..1891398c14 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1075,10 +1075,24 @@ The block name is returned." (setf (comp-limplify-pc comp-pass) (comp-block-addr bb)) (puthash (comp-block-name bb) bb (comp-func-blocks comp-func)) (cl-loop - for inst in (nthcdr (comp-limplify-pc comp-pass) + for inst-cell on (nthcdr (comp-limplify-pc comp-pass) (comp-func-lap comp-func)) + for inst = (car inst-cell) + for next-inst = (car-safe (cdr inst-cell)) do (comp-limplify-lap-inst inst) (cl-incf (comp-limplify-pc comp-pass)) + when (comp-lap-fall-through-p inst) + do (pcase next-inst + (`(TAG ,_label . ,label-sp) + (when label-sp + (cl-assert (= (1- label-sp) (comp-sp)))) + (let* ((stack-depth (if label-sp + (1- label-sp) + (comp-sp))) + (next-bb (comp-add-pending-block stack-depth))) + (unless (comp-block-closed bb) + (comp-emit `(jump ,next-bb)))) + (cl-return))) until (comp-lap-eob-p inst))) (defun comp-limplify-function (func) commit 10c6303d242ce8f01f38e78da71d01c7a379e651 Author: Andrea Corallo Date: Sun Oct 27 16:11:56 2019 +0100 fix invalid write into emit_limple_insn diff --git a/src/comp.c b/src/comp.c index a7a5ce0dcb..3b124bef23 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1182,7 +1182,8 @@ emit_limple_insn (Lisp_Object insn) unsigned i = 0; FOR_EACH_TAIL (p) { - eassert (i < sizeof (arg)); + if (i == sizeof (arg) / sizeof (Lisp_Object)) + break; arg[i++] = XCAR (p); } commit 96bca89e5b03b6d5ab7ac8bda8216adfc1911205 Author: Andrea Corallo Date: Sun Oct 27 15:55:08 2019 +0100 fix subr name within comp-limplify-lap-inst diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index d7abb8bfa1..7b77b4d87c 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -885,7 +885,7 @@ the annotation emission." (byte-preceding-char preceding-char) (byte-current-column auto) (byte-indent-to - (comp-emit-set-call (comp-call 'indent_to + (comp-emit-set-call (comp-call 'indent-to (comp-slot) (make-comp-mvar :constant nil)))) (byte-scan-buffer-OBSOLETE) @@ -908,7 +908,7 @@ the annotation emission." (byte-buffer-substring auto) (byte-delete-region auto) (byte-narrow-to-region - (comp-emit-set-call (comp-call 'narrow_to_region + (comp-emit-set-call (comp-call 'narrow-to-region (comp-slot) (comp-slot+1)))) (byte-widen commit 475b4768c856c0a25ee236faf0c30b39d5cd804a Author: Andrea Corallo Date: Sun Oct 27 15:16:59 2019 +0100 simplify comp-limplify-block diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 858a49b280..d7abb8bfa1 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1075,24 +1075,10 @@ The block name is returned." (setf (comp-limplify-pc comp-pass) (comp-block-addr bb)) (puthash (comp-block-name bb) bb (comp-func-blocks comp-func)) (cl-loop - for inst-cell on (nthcdr (comp-limplify-pc comp-pass) + for inst in (nthcdr (comp-limplify-pc comp-pass) (comp-func-lap comp-func)) - for inst = (car inst-cell) - for next-inst = (car-safe (cdr inst-cell)) do (comp-limplify-lap-inst inst) (cl-incf (comp-limplify-pc comp-pass)) - when (comp-lap-fall-through-p inst) - do (pcase next-inst - (`(TAG ,_label . ,label-sp) - (when label-sp - (cl-assert (= (1- label-sp) (comp-sp)))) - (let* ((stack-depth (if label-sp - (1- label-sp) - (comp-sp))) - (next-bb (comp-add-pending-block stack-depth))) - (unless (comp-block-closed bb) - (comp-emit `(jump ,next-bb)))) - (cl-return))) until (comp-lap-eob-p inst))) (defun comp-limplify-function (func) commit 67ac8603eaa5618622d746f4097a0ba6ca2f76b3 Author: Andrea Corallo Date: Sun Oct 27 10:24:03 2019 +0100 better comp-limplify-block do not non fall through blocks diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index b02f846eb9..858a49b280 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1079,21 +1079,18 @@ The block name is returned." (comp-func-lap comp-func)) for inst = (car inst-cell) for next-inst = (car-safe (cdr inst-cell)) - for fall-through = (comp-lap-fall-through-p inst) do (comp-limplify-lap-inst inst) (cl-incf (comp-limplify-pc comp-pass)) - (pcase next-inst + when (comp-lap-fall-through-p inst) + do (pcase next-inst (`(TAG ,_label . ,label-sp) - (when (and label-sp fall-through) + (when label-sp (cl-assert (= (1- label-sp) (comp-sp)))) (let* ((stack-depth (if label-sp (1- label-sp) - (if fall-through - (comp-sp) - (error "Unknown stack depth.")))) - (next-bb (comp-add-pending-block stack-depth))) - (when (and fall-through - (not (comp-block-closed bb))) + (comp-sp))) + (next-bb (comp-add-pending-block stack-depth))) + (unless (comp-block-closed bb) (comp-emit `(jump ,next-bb)))) (cl-return))) until (comp-lap-eob-p inst))) commit 45158ed98b345145eb3e9f8c27b0591433465ff1 Author: Andrea Corallo Date: Thu Oct 24 22:20:38 2019 +0200 promote a couple of small functions tu subst diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index cda6cdf358..b02f846eb9 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -545,8 +545,9 @@ The basic block is returned." "Return a clean frame of meta variables of size SIZE." (cl-loop with v = (make-vector size nil) for i below size - for mvar = (if ssa (make-comp-ssa-mvar :slot i) - (make-comp-mvar :slot i)) + for mvar = (if ssa + (make-comp-ssa-mvar :slot i) + (make-comp-mvar :slot i)) do (aset v i mvar) finally (return v))) @@ -561,7 +562,7 @@ The basic block is returned." NOTE: this is used for late fixup therefore ignore if the basic block is closed." (setf (comp-block-insns bb) (nconc (comp-block-insns bb) (list insn)))) -(defun comp-emit-set-call (call) +(defsubst comp-emit-set-call (call) "Emit CALL assigning the result the the current slot frame. If the callee function is known to have a return type propagate it." (cl-assert call) @@ -575,7 +576,7 @@ If DST-N is specified use it otherwise assume it to be the current slot." (cl-assert src-slot) (comp-emit `(set ,(comp-slot) ,src-slot))))) -(defun comp-emit-annotation (str) +(defsubst comp-emit-annotation (str) "Emit annotation STR." (comp-emit `(comment ,str))) commit cf72d9de0f46960d260e3f5eba843ff01f30eff0 Author: Andrea Corallo Date: Thu Oct 24 22:19:14 2019 +0200 emit TAG number as comment diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index f41731951e..cda6cdf358 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -796,10 +796,11 @@ the annotation emission." (cdr insn)))) (comp-op-case (TAG - (cl-destructuring-bind (_TAG _label-num . label-sp) insn + (cl-destructuring-bind (_TAG label-num . label-sp) insn ;; Paranoid? (when label-sp - (cl-assert (= (1- label-sp) (comp-limplify-sp comp-pass)))))) + (cl-assert (= (1- label-sp) (comp-limplify-sp comp-pass)))) + (comp-emit-annotation (format "LAP TAG %d" label-num)))) (byte-stack-ref (comp-copy-slot (- (comp-sp) arg 1))) (byte-varref commit face460c41f59b5097748159ce64a5a09b277dc7 Author: Andrea Corallo Date: Thu Oct 24 22:13:29 2019 +0200 make more robust comp-emit-uncond-jump diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index cf779179d7..f41731951e 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -610,7 +610,8 @@ The block is returned." (defun comp-emit-uncond-jump (lap-label) "Emit an unconditional branch to LAP-LABEL." (cl-destructuring-bind (label-num . stack-depth) lap-label - (cl-assert (= (1- stack-depth) (comp-sp))) + (when stack-depth + (cl-assert (= (1- stack-depth) (comp-sp)))) (let ((target (comp-lap-to-limple-bb label-num))) (comp-block-maybe-mark-pending :name target :sp (comp-sp) commit 59f7b155119b5718b83f0bac7409dd597002c89b Author: Andrea Corallo Date: Thu Oct 24 15:03:03 2019 +0200 fix comp-limplify-block for wrong cl func usage diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index d9b0c18462..cf779179d7 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1092,7 +1092,7 @@ The block name is returned." (when (and fall-through (not (comp-block-closed bb))) (comp-emit `(jump ,next-bb)))) - (return))) + (cl-return))) until (comp-lap-eob-p inst))) (defun comp-limplify-function (func) commit 1d3c0d1716eb2025c1dd2e07195b55bb5781fdd3 Author: Andrea Corallo Date: Thu Oct 24 14:36:28 2019 +0200 fix compilation when modules are enabled diff --git a/configure.ac b/configure.ac index 0cfd80bb2e..c86dac6a65 100644 --- a/configure.ac +++ b/configure.ac @@ -3671,23 +3671,6 @@ if test "${HAVE_ZLIB}" = "yes"; then fi AC_SUBST(LIBZ) -### Emacs Lisp native compiler support -HAVE_NATIVE_COMP=no -LIBGCCJIT_LIB= -COMP_OBJ= -if test "${with_nativecomp}" != "no"; then - AC_CHECK_LIB(gccjit, gcc_jit_context_acquire, HAVE_NATIVE_COMP=yes, , -lgccjit) - if test "${HAVE_NATIVE_COMP}" = "yes"; then - LIBGCCJIT_LIB="-lgccjit -ldl" - COMP_OBJ="dynlib.o comp.o" - AC_DEFINE(HAVE_NATIVE_COMP, 1, [Define to 1 if you have the libgccjit library (-lgccjit).]) - AC_DEFINE_UNQUOTED(NATIVE_ELISP_SUFFIX, ".eln", - [System extension for native compiled elisp]) - fi -fi -AC_SUBST(LIBGCCJIT_LIB) -AC_SUBST(COMP_OBJ) - ### Dynamic modules support LIBMODULES= HAVE_MODULES=no @@ -3754,6 +3737,28 @@ module_env_snippet_28="$srcdir/src/module-env-28.h" emacs_major_version="${PACKAGE_VERSION%%.*}" AC_SUBST(emacs_major_version) +### Emacs Lisp native compiler support +HAVE_NATIVE_COMP=no +LIBGCCJIT_LIB= +COMP_OBJ= +if test "${with_nativecomp}" != "no"; then + AC_CHECK_LIB(gccjit, gcc_jit_context_acquire, HAVE_NATIVE_COMP=yes, , -lgccjit) + if test "${HAVE_NATIVE_COMP}" = "yes"; then + LIBGCCJIT_LIB="-lgccjit -ldl" + if test "${HAVE_MODULES}" = yes; then + COMP_OBJ="comp.o" + else + COMP_OBJ="dynlib.o comp.o" + fi + AC_DEFINE(HAVE_NATIVE_COMP, 1, [Define to 1 if you have the libgccjit library (-lgccjit).]) + AC_DEFINE_UNQUOTED(NATIVE_ELISP_SUFFIX, ".eln", + [System extension for native compiled elisp]) + fi +fi +AC_SUBST(LIBGCCJIT_LIB) +AC_SUBST(COMP_OBJ) + + ### Use -lpng if available, unless '--with-png=no'. HAVE_PNG=no LIBPNG= commit adac6fa11a95b5c3dd5ae5766b1539687d5931f5 Author: Andrea Corallo Date: Mon Oct 21 11:30:39 2019 +0200 make non local handler bb generation robust for all order of creation diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 9ce1e96b3c..d9b0c18462 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -511,12 +511,14 @@ Restore the original value afterwards." The basic block is returned." (if-let ((bb (gethash name (comp-func-blocks comp-func)))) ;; If was already declared sanity check sp. - (cl-assert (or (null sp) (= sp (comp-block-sp bb))) - (sp (comp-block-sp bb)) "sp %d %d differs") - ;; Mark it pending in case is not already. - (unless (cl-find-if (lambda (bb) - (eq (comp-block-name bb) name)) - (comp-limplify-pending-blocks comp-pass)) + (progn + (cl-assert (or (null sp) (= sp (comp-block-sp bb))) + (sp (comp-block-sp bb)) "sp %d %d differs") + bb) + ;; Look into the pendings and add the a new one there if necessary. + (or (cl-find-if (lambda (bb) + (eq (comp-block-name bb) name)) + (comp-limplify-pending-blocks comp-pass)) (car (push (apply #'make--comp-block args) (comp-limplify-pending-blocks comp-pass)))))) @@ -548,12 +550,17 @@ The basic block is returned." do (aset v i mvar) finally (return v))) -(defsubst comp-emit (insn &optional bb) - "Emit INSN in BB is specified or the current basic block otherwise." - (let ((bb (or bb (comp-limplify-curr-block comp-pass)))) +(defsubst comp-emit (insn) + "Emit INSN into basic block BB." + (let ((bb (comp-limplify-curr-block comp-pass))) (cl-assert (not (comp-block-closed bb))) (push insn (comp-block-insns bb)))) +(defsubst comp-emit-as-head (insn bb) + "Emit INSN at the head of basic block BB. +NOTE: this is used for late fixup therefore ignore if the basic block is closed." + (setf (comp-block-insns bb) (nconc (comp-block-insns bb) (list insn)))) + (defun comp-emit-set-call (call) "Emit CALL assigning the result the the current slot frame. If the callee function is known to have a return type propagate it." @@ -656,7 +663,7 @@ Return value is the fall through block name." handler-name guarded-name)) (setf (comp-block-closed (comp-limplify-curr-block comp-pass)) t) - (comp-emit `(fetch-handler ,(comp-slot+1) ,handler-buff-n) handler-bb) + (comp-emit-as-head `(fetch-handler ,(comp-slot+1) ,handler-buff-n) handler-bb) (cl-incf (comp-func-handler-cnt comp-func))))) (defun comp-limplify-listn (n) commit 4847522fd4030af7ddb92b789545bc4e253524ee Author: Andrea Corallo Date: Mon Oct 21 11:04:18 2019 +0200 some clean-up diff --git a/src/comp.c b/src/comp.c index f71df79418..a7a5ce0dcb 100644 --- a/src/comp.c +++ b/src/comp.c @@ -37,13 +37,6 @@ along with GNU Emacs. If not, see . */ #define COMP_DEBUG 1 -/* - If 1 always favorite the emission of direct constants when these are know - instead of the corresponding frame slot access. - This has to prove to have some perf advantage but certainly makes the - generated code C-like code more bloated. -*/ - /* C symbols emited for the load relocation mechanism. */ #define DATA_RELOC_SYM "d_reloc" #define IMPORTED_FUNC_RELOC_SYM "f_reloc" @@ -60,10 +53,6 @@ along with GNU Emacs. If not, see . */ XCAR (XCDR (x)) #define THIRD(x) \ XCAR (XCDR (XCDR (x))) -#define FORTH(x) \ - XCAR (XCDR (XCDR (XCDR (x)))) -#define FIFTH(x) \ - XCAR (XCDR (XCDR (XCDR (XCDR (x))))) #define FUNCALL1(fun, arg) \ CALLN (Ffuncall, intern_c_string (STR(fun)), arg) commit 96e2863f2e85bc907e5fc0cb7d86e0b6ff54317a Author: Andrea Corallo Date: Mon Oct 21 10:51:25 2019 +0200 rework emit_limple_insn arg parsing diff --git a/src/comp.c b/src/comp.c index 6b3ca832d9..f71df79418 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1186,35 +1186,30 @@ emit_limple_insn (Lisp_Object insn) { Lisp_Object op = XCAR (insn); Lisp_Object args = XCDR (insn); - Lisp_Object arg0 UNINIT; gcc_jit_rvalue *res; - Lisp_Object arg[6]; + Lisp_Object p = XCDR (insn); - ptrdiff_t n_args = list_length (p); unsigned i = 0; FOR_EACH_TAIL (p) { - eassert (i < n_args); + eassert (i < sizeof (arg)); arg[i++] = XCAR (p); } - if (CONSP (args)) - arg0 = XCAR (args); - if (EQ (op, Qjump)) { /* Unconditional branch. */ - gcc_jit_block *target = retrive_block (arg0); + gcc_jit_block *target = retrive_block (arg[0]); gcc_jit_block_end_with_jump (comp.block, NULL, target); } else if (EQ (op, Qcond_jump)) { /* Conditional branch. */ - gcc_jit_rvalue *a = emit_mvar_val (arg0); - gcc_jit_rvalue *b = emit_mvar_val (SECOND (args)); - gcc_jit_block *target1 = retrive_block (THIRD (args)); - gcc_jit_block *target2 = retrive_block (FORTH (args)); + gcc_jit_rvalue *a = emit_mvar_val (arg[0]); + gcc_jit_rvalue *b = emit_mvar_val (arg[1]); + gcc_jit_block *target1 = retrive_block (arg[2]); + gcc_jit_block *target2 = retrive_block (arg[3]); emit_cond_jump (emit_EQ (a, b), target2, target1); } @@ -1229,9 +1224,9 @@ emit_limple_insn (Lisp_Object insn) gcc_jit_rvalue *n = gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.ptrdiff_type, - XFIXNUM (arg0)); - gcc_jit_block *target1 = retrive_block (SECOND (args)); - gcc_jit_block *target2 = retrive_block (THIRD (args)); + XFIXNUM (arg[0])); + gcc_jit_block *target1 = retrive_block (arg[1]); + gcc_jit_block *target2 = retrive_block (arg[2]); gcc_jit_rvalue *test = gcc_jit_context_new_comparison ( comp.ctxt, NULL, @@ -1264,7 +1259,7 @@ emit_limple_insn (Lisp_Object insn) gcc_jit_block *handler_bb = retrive_block (arg[3]); gcc_jit_block *guarded_bb = retrive_block (arg[4]); emit_limple_push_handler (handler, handler_type, handler_buff_n, - handler_bb, guarded_bb, arg0); + handler_bb, guarded_bb, arg[0]); } else if (EQ (op, Qpop_handler)) { @@ -1290,7 +1285,7 @@ emit_limple_insn (Lisp_Object insn) } else if (EQ (op, Qfetch_handler)) { - EMACS_UINT handler_buff_n = XFIXNUM (SECOND (args)); + EMACS_UINT handler_buff_n = XFIXNUM (arg[1]); gcc_jit_lvalue *c = xmint_pointer (AREF (comp.buffer_handler_vec, handler_buff_n)); gcc_jit_lvalue *m_handlerlist = @@ -1306,7 +1301,7 @@ emit_limple_insn (Lisp_Object insn) NULL, comp.handler_next_field))); emit_frame_assignment ( - arg0, + arg[0], gcc_jit_lvalue_as_rvalue( gcc_jit_rvalue_dereference_field (gcc_jit_lvalue_as_rvalue (c), NULL, @@ -1335,7 +1330,7 @@ emit_limple_insn (Lisp_Object insn) } else if (EQ (op, Qset)) { - Lisp_Object arg1 = SECOND (args); + Lisp_Object arg1 = arg[1]; if (EQ (Ftype_of (arg1), Qcomp_mvar)) res = emit_mvar_val (arg1); @@ -1352,16 +1347,16 @@ emit_limple_insn (Lisp_Object insn) ICE_IF (!res, gcc_jit_context_get_first_error (comp.ctxt)); - emit_frame_assignment (arg0, res); + emit_frame_assignment (arg[0], res); } else if (EQ (op, Qset_par_to_local)) { /* Ex: (setpar #s(comp-mvar 2 0 nil nil nil) 0). */ - EMACS_UINT param_n = XFIXNUM (SECOND (args)); + EMACS_UINT param_n = XFIXNUM (arg[1]); gcc_jit_rvalue *param = gcc_jit_param_as_rvalue (gcc_jit_function_get_param (comp.func, param_n)); - emit_frame_assignment (arg0, param); + emit_frame_assignment (arg[0], param); } else if (EQ (op, Qset_args_to_local)) { @@ -1376,7 +1371,7 @@ emit_limple_insn (Lisp_Object insn) gcc_jit_rvalue *res = gcc_jit_lvalue_as_rvalue (gcc_jit_rvalue_dereference (gcc_args, NULL)); - emit_frame_assignment (arg0, res); + emit_frame_assignment (arg[0], res); } else if (EQ (op, Qset_rest_args_to_local)) { @@ -1385,7 +1380,7 @@ emit_limple_insn (Lisp_Object insn) C: local[2] = list (nargs - 2, args); */ - EMACS_UINT slot_n = XFIXNUM (FUNCALL1 (comp-mvar-slot, arg0)); + EMACS_UINT slot_n = XFIXNUM (FUNCALL1 (comp-mvar-slot, arg[0])); gcc_jit_rvalue *n = gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.ptrdiff_type, @@ -1407,7 +1402,7 @@ emit_limple_insn (Lisp_Object insn) res = emit_call (Qlist, comp.lisp_obj_type, 2, list_args, false); - emit_frame_assignment (arg0, res); + emit_frame_assignment (arg[0], res); } else if (EQ (op, Qinc_args)) { @@ -1433,10 +1428,10 @@ emit_limple_insn (Lisp_Object insn) gcc_jit_rvalue *reloc_n = gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.int_type, - XFIXNUM (SECOND (args))); - emit_comment (SSDATA (Fprin1_to_string (THIRD (args), Qnil))); + XFIXNUM (arg[1])); + emit_comment (SSDATA (Fprin1_to_string (arg[2], Qnil))); emit_frame_assignment ( - arg0, + arg[0], gcc_jit_lvalue_as_rvalue ( gcc_jit_context_new_array_access (comp.ctxt, NULL, @@ -1446,13 +1441,13 @@ emit_limple_insn (Lisp_Object insn) else if (EQ (op, Qcomment)) { /* Ex: (comment "Function: foo"). */ - emit_comment((char *) SDATA (arg0)); + emit_comment (SSDATA (arg[0])); } else if (EQ (op, Qreturn)) { gcc_jit_block_end_with_return (comp.block, NULL, - emit_mvar_val (arg0)); + emit_mvar_val (arg[0])); } else { commit 8d08a8a1070435e12b77517808df34a8093abc67 Author: Andrea Corallo Date: Sun Oct 20 21:00:17 2019 +0200 add fetch-handler operator diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 34e0d02e3b..9ce1e96b3c 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -92,7 +92,7 @@ Can be used by code that wants to expand differently in this case.") set-rest-args-to-local) "Limple set operators.") -(defconst comp-limple-assignments `(push-handler +(defconst comp-limple-assignments `(fetch-handler ,@comp-limple-sets) "Limple operators that clobbers the first mvar argument.") @@ -217,7 +217,9 @@ structure.") (edge-cnt-gen (funcall #'comp-gen-counter) :type function :documentation "Generates edges numbers.") (ssa-cnt-gen (funcall #'comp-gen-counter) :type function - :documentation "Counter to create ssa limple vars.")) + :documentation "Counter to create ssa limple vars.") + (handler-cnt 0 :type number + :documentation "Number of non local handler buffers.")) (defun comp-func-reset-generators (func) "Reset unique id generators for FUNC." @@ -505,7 +507,8 @@ Restore the original value afterwards." (error "Can't find label %d" label))) (cl-defun comp-block-maybe-mark-pending (&rest args &key name sp &allow-other-keys) - "Create a basic block and mark it as pending." + "Create a basic block and mark it as pending. +The basic block is returned." (if-let ((bb (gethash name (comp-func-blocks comp-func)))) ;; If was already declared sanity check sp. (cl-assert (or (null sp) (= sp (comp-block-sp bb))) @@ -514,8 +517,8 @@ Restore the original value afterwards." (unless (cl-find-if (lambda (bb) (eq (comp-block-name bb) name)) (comp-limplify-pending-blocks comp-pass)) - (push (apply #'make--comp-block args) - (comp-limplify-pending-blocks comp-pass))))) + (car (push (apply #'make--comp-block args) + (comp-limplify-pending-blocks comp-pass)))))) (defun comp-call (func &rest args) "Emit a call for function FUNC with ARGS." @@ -545,10 +548,11 @@ Restore the original value afterwards." do (aset v i mvar) finally (return v))) -(defsubst comp-emit (insn) - "Emit INSN into current basic block." - (cl-assert (not (comp-block-closed (comp-limplify-curr-block comp-pass)))) - (push insn (comp-block-insns (comp-limplify-curr-block comp-pass)))) +(defsubst comp-emit (insn &optional bb) + "Emit INSN in BB is specified or the current basic block otherwise." + (let ((bb (or bb (comp-limplify-curr-block comp-pass)))) + (cl-assert (not (comp-block-closed bb))) + (push insn (comp-block-insns bb)))) (defun comp-emit-set-call (call) "Emit CALL assigning the result the the current slot frame. @@ -634,22 +638,26 @@ Return value is the fall through block name." (defun comp-emit-handler (lap-label handler-type) "Emit a non local exit handler to LAP-LABEL of type HANDLER-TYPE." (cl-destructuring-bind (label-num . label-sp) lap-label - (let ((guarded-bb (comp-new-block-sym)) - (handler-bb (comp-lap-to-limple-bb label-num))) - (cl-assert (= (- label-sp 2) (comp-sp))) - (comp-block-maybe-mark-pending :name guarded-bb + (cl-assert (= (- label-sp 2) (comp-sp))) + (let* ((guarded-name (comp-new-block-sym)) + (handler-name (comp-lap-to-limple-bb label-num)) + (handler-buff-n (comp-func-handler-cnt comp-func)) + (handler-bb (comp-block-maybe-mark-pending :name handler-name + :sp (1+ (comp-sp)) + :addr + (comp-label-to-addr label-num)))) + (comp-block-maybe-mark-pending :name guarded-name :sp (comp-sp) :addr (1+ (comp-limplify-pc comp-pass))) - (comp-block-maybe-mark-pending :name handler-bb - :sp (1+ (comp-sp)) - :addr (comp-label-to-addr label-num)) (comp-emit (list 'push-handler - (comp-slot+1) - (comp-slot+1) handler-type - handler-bb - guarded-bb)) - (setf (comp-block-closed (comp-limplify-curr-block comp-pass)) t)))) + (comp-slot+1) + handler-buff-n + handler-name + guarded-name)) + (setf (comp-block-closed (comp-limplify-curr-block comp-pass)) t) + (comp-emit `(fetch-handler ,(comp-slot+1) ,handler-buff-n) handler-bb) + (cl-incf (comp-func-handler-cnt comp-func))))) (defun comp-limplify-listn (n) "Limplify list N." diff --git a/src/comp.c b/src/comp.c index be966c2709..6b3ca832d9 100644 --- a/src/comp.c +++ b/src/comp.c @@ -171,6 +171,7 @@ typedef struct { Lisp_Object func_blocks_h; /* blk_name -> gcc_block. */ Lisp_Object exported_funcs_h; /* subr_name -> gcc_jit_function *. */ Lisp_Object imported_funcs_h; /* subr_name -> reloc_field. */ + Lisp_Object buffer_handler_vec; /* All locals used to store non local exit values. */ Lisp_Object emitter_dispatcher; gcc_jit_rvalue *data_relocs; /* Synthesized struct holding data relocs. */ gcc_jit_lvalue *func_relocs; /* Synthesized struct holding func relocs. */ @@ -280,7 +281,7 @@ retrive_block (Lisp_Object block_name) static void declare_block (Lisp_Object block_name) { - char *name_str = (char *) SDATA (SYMBOL_NAME (block_name)); + char *name_str = SSDATA (SYMBOL_NAME (block_name)); gcc_jit_block *block = gcc_jit_function_new_block (comp.func, name_str); Lisp_Object value = make_mint_ptr (block); ICE_IF (!NILP (Fgethash (block_name, comp.func_blocks_h, Qnil)), @@ -1151,23 +1152,12 @@ emit_limple_call_ref (Lisp_Object insn, bool direct) static void emit_limple_push_handler (gcc_jit_rvalue *handler, gcc_jit_rvalue *handler_type, - gcc_jit_block *handler_bb, gcc_jit_block *guarded_bb, - Lisp_Object clobbered_mvar) + EMACS_UINT handler_buff_n, gcc_jit_block *handler_bb, + gcc_jit_block *guarded_bb, Lisp_Object clobbered_mvar) { - /* - Ex: (push-handler #s(comp-mvar 1 8 nil nil nil nil) - #s(comp-mvar 1 7 t done symbol nil) - catcher bb_2 bb_1). - */ - - static unsigned pushhandler_n; /* FIXME move at ctxt or func level. */ - - /* struct handler *c = push_handler (POP, type); */ + /* struct handler *c = push_handler (POP, type); */ gcc_jit_lvalue *c = - gcc_jit_function_new_local (comp.func, - NULL, - comp.handler_ptr_type, - format_string ("c_%u", pushhandler_n)); + xmint_pointer (AREF (comp.buffer_handler_vec, handler_buff_n)); gcc_jit_rvalue *args[] = { handler, handler_type }; gcc_jit_block_add_assignment ( @@ -1189,29 +1179,6 @@ emit_limple_push_handler (gcc_jit_rvalue *handler, gcc_jit_rvalue *handler_type, res = emit_call (intern_c_string (SETJMP_NAME), comp.int_type, 1, args, false); emit_cond_jump (res, handler_bb, guarded_bb); - - /* This emit the handler part. */ - - comp.block = handler_bb; - gcc_jit_lvalue *m_handlerlist = - gcc_jit_rvalue_dereference_field (comp.current_thread, - NULL, - comp.m_handlerlist); - gcc_jit_block_add_assignment ( - comp.block, - NULL, - m_handlerlist, - gcc_jit_lvalue_as_rvalue( - gcc_jit_rvalue_dereference_field (gcc_jit_lvalue_as_rvalue (c), - NULL, - comp.handler_next_field))); - emit_frame_assignment ( - clobbered_mvar, - gcc_jit_lvalue_as_rvalue( - gcc_jit_rvalue_dereference_field (gcc_jit_lvalue_as_rvalue (c), - NULL, - comp.handler_val_field))); - ++pushhandler_n; } static void @@ -1222,6 +1189,16 @@ emit_limple_insn (Lisp_Object insn) Lisp_Object arg0 UNINIT; gcc_jit_rvalue *res; + Lisp_Object arg[6]; + Lisp_Object p = XCDR (insn); + ptrdiff_t n_args = list_length (p); + unsigned i = 0; + FOR_EACH_TAIL (p) + { + eassert (i < n_args); + arg[i++] = XCAR (p); + } + if (CONSP (args)) arg0 = XCAR (args); @@ -1269,9 +1246,11 @@ emit_limple_insn (Lisp_Object insn) } else if (EQ (op, Qpush_handler)) { - gcc_jit_rvalue *handler = emit_mvar_val (arg0); + /* (push-handler condition-case #s(comp-mvar 0 3 t (arith-error) cons nil) 1 bb_2 bb_1) */ + gcc_jit_rvalue *handler = emit_mvar_val (arg[1]); int h_num UNINIT; - Lisp_Object handler_spec = THIRD (args); + Lisp_Object handler_spec = arg[0]; + EMACS_UINT handler_buff_n = XFIXNUM (arg[2]); if (EQ (handler_spec, Qcatcher)) h_num = CATCHER; else if (EQ (handler_spec, Qcondition_case)) @@ -1282,10 +1261,10 @@ emit_limple_insn (Lisp_Object insn) gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.int_type, h_num); - gcc_jit_block *handler_bb = retrive_block (FORTH (args)); - gcc_jit_block *guarded_bb = retrive_block (FIFTH (args)); - emit_limple_push_handler (handler, handler_type, handler_bb, guarded_bb, - arg0); + gcc_jit_block *handler_bb = retrive_block (arg[3]); + gcc_jit_block *guarded_bb = retrive_block (arg[4]); + emit_limple_push_handler (handler, handler_type, handler_buff_n, + handler_bb, guarded_bb, arg0); } else if (EQ (op, Qpop_handler)) { @@ -1309,6 +1288,30 @@ emit_limple_insn (Lisp_Object insn) comp.handler_next_field))); } + else if (EQ (op, Qfetch_handler)) + { + EMACS_UINT handler_buff_n = XFIXNUM (SECOND (args)); + gcc_jit_lvalue *c = + xmint_pointer (AREF (comp.buffer_handler_vec, handler_buff_n)); + gcc_jit_lvalue *m_handlerlist = + gcc_jit_rvalue_dereference_field (comp.current_thread, + NULL, + comp.m_handlerlist); + gcc_jit_block_add_assignment ( + comp.block, + NULL, + m_handlerlist, + gcc_jit_lvalue_as_rvalue( + gcc_jit_rvalue_dereference_field (gcc_jit_lvalue_as_rvalue (c), + NULL, + comp.handler_next_field))); + emit_frame_assignment ( + arg0, + gcc_jit_lvalue_as_rvalue( + gcc_jit_rvalue_dereference_field (gcc_jit_lvalue_as_rvalue (c), + NULL, + comp.handler_val_field))); + } else if (EQ (op, Qcall)) { gcc_jit_block_add_eval (comp.block, NULL, @@ -2759,7 +2762,7 @@ compile_function (Lisp_Object func) frame_size), "local"); comp.frame = SAFE_ALLOCA (frame_size * sizeof (*comp.frame)); - for (unsigned i = 0; i < frame_size; ++i) + for (EMACS_INT i = 0; i < frame_size; ++i) comp.frame[i] = gcc_jit_context_new_array_access ( comp.ctxt, @@ -2789,6 +2792,16 @@ compile_function (Lisp_Object func) format_string ("local%u", i)); } + EMACS_UINT non_local_handlers = XFIXNUM (FUNCALL1 (comp-func-handler-cnt, func)); + comp.buffer_handler_vec = make_vector (non_local_handlers, Qnil); + for (unsigned i = 0; i < non_local_handlers; ++i) + ASET (comp.buffer_handler_vec, i, + make_mint_ptr ( + gcc_jit_function_new_local (comp.func, + NULL, + comp.handler_ptr_type, + format_string ("handler_%u", i)))); + comp.func_blocks_h = CALLN (Fmake_hash_table); /* Pre declare all basic blocks to gcc. @@ -3304,6 +3317,7 @@ syms_of_comp (void) /* Others. */ DEFSYM (Qpush_handler, "push-handler"); DEFSYM (Qpop_handler, "pop-handler"); + DEFSYM (Qfetch_handler, "fetch-handler"); DEFSYM (Qcondition_case, "condition-case"); /* call operands. */ DEFSYM (Qcatcher, "catcher"); /* FIXME use these allover. */ commit 7ba9a4c895b61d5c12118a18cb337f621bea4442 Author: Andrea Corallo Date: Mon Oct 21 09:53:00 2019 +0200 add autoload diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 90500b9fc3..34e0d02e3b 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1693,6 +1693,7 @@ Prepare every function for final compilation and drive the C back-end." ;;; Compiler entry points. +;;;###autoload (defun native-compile (input) "Compile INPUT into native code. This is the entrypoint for the Emacs Lisp native compiler. commit 922c4128034149abb130c6a9a06efa72659ffaf3 Author: Andrea Corallo Date: Sun Oct 20 16:04:29 2019 +0200 fix limplification when TAG follow fall through eob diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 775a0ee064..90500b9fc3 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -158,6 +158,8 @@ into it.") :documentation "Start block LAP address.") (insns () :type list :documentation "List of instructions.") + (closed nil :type boolean + :documentation "t if closed.") ;; All the followings are for SSA and CGF analysis. (in-edges () :type list :documentation "List of incoming edges.") @@ -545,6 +547,7 @@ Restore the original value afterwards." (defsubst comp-emit (insn) "Emit INSN into current basic block." + (cl-assert (not (comp-block-closed (comp-limplify-curr-block comp-pass)))) (push insn (comp-block-insns (comp-limplify-curr-block comp-pass)))) (defun comp-emit-set-call (call) @@ -601,7 +604,8 @@ The block is returned." (comp-block-maybe-mark-pending :name target :sp (comp-sp) :addr (comp-label-to-addr label-num)) - (comp-emit `(jump ,target))))) + (comp-emit `(jump ,target)) + (setf (comp-block-closed (comp-limplify-curr-block comp-pass)) t)))) (defun comp-emit-cond-jump (a b target-offset lap-label negated) "Emit a conditional jump to LAP-LABEL when A and B satisfy EQ. @@ -624,6 +628,7 @@ Return value is the fall through block name." (comp-emit (if negated (list 'cond-jump a b target bb) (list 'cond-jump a b bb target))) + (setf (comp-block-closed (comp-limplify-curr-block comp-pass)) t) bb))) (defun comp-emit-handler (lap-label handler-type) @@ -643,7 +648,8 @@ Return value is the fall through block name." (comp-slot+1) handler-type handler-bb - guarded-bb))))) + guarded-bb)) + (setf (comp-block-closed (comp-limplify-curr-block comp-pass)) t)))) (defun comp-limplify-listn (n) "Limplify list N." @@ -1068,7 +1074,8 @@ The block name is returned." (comp-sp) (error "Unknown stack depth.")))) (next-bb (comp-add-pending-block stack-depth))) - (when fall-through + (when (and fall-through + (not (comp-block-closed bb))) (comp-emit `(jump ,next-bb)))) (return))) until (comp-lap-eob-p inst))) commit e4684a2f9d07ca6ad836028514dda8e3e6643bf8 Author: Andrea Corallo Date: Sun Oct 20 15:24:18 2019 +0200 fix ice logging message diff --git a/src/comp.c b/src/comp.c index 039daeeaad..be966c2709 100644 --- a/src/comp.c +++ b/src/comp.c @@ -218,10 +218,9 @@ static void ice (const char* msg) { if (msg) - msg = format_string ("Internal native compiler error: %s", msg); + error ("Internal native compiler error: %s", msg); else - msg = "Internal native compiler error"; - error ("%s", msg); + error ("Internal native compiler error"); } static void commit eab243d22203e0aa56576b00568a93f18e8196cd Author: Andrea Corallo Date: Sun Oct 20 14:42:06 2019 +0200 do not check label stack depth when this is not provided diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 4dd6cbce43..775a0ee064 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -613,7 +613,8 @@ Return value is the fall through block name." (let ((bb (comp-new-block-sym)) ; Fall through block. (target (comp-lap-to-limple-bb label-num)) (target-sp (+ target-offset (comp-sp)))) - (cl-assert (= (1- label-sp) (+ target-offset (comp-sp)))) + (when label-sp + (cl-assert (= (1- label-sp) (+ target-offset (comp-sp))))) (comp-block-maybe-mark-pending :name bb :sp (comp-sp) :addr (1+ (comp-limplify-pc comp-pass))) @@ -773,8 +774,10 @@ the annotation emission." (cdr insn)))) (comp-op-case (TAG - ;; Paranoically sanity check stack depth. - (cl-assert (= (1- (cddr insn)) (comp-limplify-sp comp-pass)))) + (cl-destructuring-bind (_TAG _label-num . label-sp) insn + ;; Paranoid? + (when label-sp + (cl-assert (= (1- label-sp) (comp-limplify-sp comp-pass)))))) (byte-stack-ref (comp-copy-slot (- (comp-sp) arg 1))) (byte-varref @@ -1057,9 +1060,14 @@ The block name is returned." (cl-incf (comp-limplify-pc comp-pass)) (pcase next-inst (`(TAG ,_label . ,label-sp) - (when fall-through + (when (and label-sp fall-through) (cl-assert (= (1- label-sp) (comp-sp)))) - (let ((next-bb (comp-add-pending-block (1- label-sp)))) + (let* ((stack-depth (if label-sp + (1- label-sp) + (if fall-through + (comp-sp) + (error "Unknown stack depth.")))) + (next-bb (comp-add-pending-block stack-depth))) (when fall-through (comp-emit `(jump ,next-bb)))) (return))) commit 50604ff3872a46baec8578b35db92d9892a35396 Author: Andrea Corallo Date: Sun Oct 20 11:10:22 2019 +0200 fix missing jump into comp-emit-narg-prologue diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 03ace885f8..4dd6cbce43 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -982,11 +982,13 @@ the annotation emission." (comp-emit `(set-args-to-local ,(comp-slot-n i))) (comp-emit '(inc-args)) finally (comp-emit '(jump entry_rest_args))) - (cl-loop for i from minarg below nonrest - do (comp-with-sp i - (comp-make-curr-block (intern (format "entry_fallback_%s" i)) - (comp-sp)) - (comp-emit-set-const nil))) + (when (not (= minarg nonrest)) + (cl-loop for i from minarg below nonrest + do (comp-with-sp i + (comp-make-curr-block (intern (format "entry_fallback_%s" i)) + (comp-sp)) + (comp-emit-set-const nil)) + finally (comp-emit '(jump entry_rest_args)))) (comp-make-curr-block 'entry_rest_args (comp-sp)) (comp-emit `(set-rest-args-to-local ,(comp-slot-n nonrest)))) commit 63a1f317d05c8eed256251e7952e621a37b5cf7b Author: Andrea Corallo Date: Sun Oct 20 11:02:16 2019 +0200 fix comp-limplify-block when falling through a return diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index fe3c1dde93..03ace885f8 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1054,10 +1054,10 @@ The block name is returned." do (comp-limplify-lap-inst inst) (cl-incf (comp-limplify-pc comp-pass)) (pcase next-inst - (`(TAG ,_label . ,target-sp) + (`(TAG ,_label . ,label-sp) (when fall-through - (cl-assert (= (1- target-sp) (comp-sp)))) - (let ((next-bb (comp-add-pending-block (comp-sp)))) + (cl-assert (= (1- label-sp) (comp-sp)))) + (let ((next-bb (comp-add-pending-block (1- label-sp)))) (when fall-through (comp-emit `(jump ,next-bb)))) (return))) commit f24c0c7111d9a11921c057eb8d77ca4287294c0d Author: Andrea Corallo Date: Sun Oct 20 10:40:28 2019 +0200 log a page break when start compiling diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index a0ff122362..fe3c1dde93 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1690,6 +1690,7 @@ If INPUT is a string, use it as the file path to be native compiled." :output (if (symbolp input) (symbol-name input) (file-name-sans-extension (expand-file-name input)))))) + (comp-log "\n \n") (mapc (lambda (pass) (comp-log (format "Running pass %s:\n" pass)) (setq data (funcall pass data))) commit 689bb582623450826a9e2cdcc2aa63aaa6ab5764 Author: Andrea Corallo Date: Sun Oct 20 10:39:59 2019 +0200 update emit-handler + rework comp-emit-cond-jump diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index a01fce22d7..a0ff122362 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -455,7 +455,7 @@ Points to the next slot to be filled.") (defconst comp-lap-eob-ops '(byte-goto byte-goto-if-nil byte-goto-if-not-nil byte-goto-if-nil-else-pop byte-goto-if-not-nil-else-pop byte-return byte-pushcatch - byte-switch) + byte-switch byte-pushconditioncase) "LAP end of basic blocks op codes.") (defsubst comp-lap-eob-p (inst) @@ -609,11 +609,11 @@ TARGET-OFFSET is the positive offset on the SP when branching to the target block. If NEGATED non null negate the tested condition. Return value is the fall through block name." - (cl-destructuring-bind (label-num . target-sp) lap-label - (let ((target-sp (1- target-sp)) - (bb (comp-new-block-sym)) ; Fall through block. - (target (comp-lap-to-limple-bb label-num))) - (cl-assert (= target-sp (+ target-offset (comp-sp)))) + (cl-destructuring-bind (label-num . label-sp) lap-label + (let ((bb (comp-new-block-sym)) ; Fall through block. + (target (comp-lap-to-limple-bb label-num)) + (target-sp (+ target-offset (comp-sp)))) + (cl-assert (= (1- label-sp) (+ target-offset (comp-sp)))) (comp-block-maybe-mark-pending :name bb :sp (comp-sp) :addr (1+ (comp-limplify-pc comp-pass))) @@ -627,15 +627,15 @@ Return value is the fall through block name." (defun comp-emit-handler (lap-label handler-type) "Emit a non local exit handler to LAP-LABEL of type HANDLER-TYPE." - (cl-destructuring-bind (label-num . stack-depth) lap-label - (cl-assert (= stack-depth (comp-sp))) + (cl-destructuring-bind (label-num . label-sp) lap-label (let ((guarded-bb (comp-new-block-sym)) (handler-bb (comp-lap-to-limple-bb label-num))) + (cl-assert (= (- label-sp 2) (comp-sp))) (comp-block-maybe-mark-pending :name guarded-bb - :sp stack-depth + :sp (comp-sp) :addr (1+ (comp-limplify-pc comp-pass))) (comp-block-maybe-mark-pending :name handler-bb - :sp (1+ stack-depth) + :sp (1+ (comp-sp)) :addr (comp-label-to-addr label-num)) (comp-emit (list 'push-handler (comp-slot+1) @@ -1057,7 +1057,7 @@ The block name is returned." (`(TAG ,_label . ,target-sp) (when fall-through (cl-assert (= (1- target-sp) (comp-sp)))) - (let ((next-bb (comp-add-pending-block (1- target-sp)))) + (let ((next-bb (comp-add-pending-block (comp-sp)))) (when fall-through (comp-emit `(jump ,next-bb)))) (return))) commit aadb83da748c6befaabab0583fd38bac7fb094ba Author: Andrea Corallo Date: Sun Oct 20 09:32:57 2019 +0200 fix initial sp value diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 95fbe9f2de..a01fce22d7 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -442,8 +442,9 @@ If INPUT is a string this is the file path to be compiled." :documentation "Meta-stack used to flat LAP.") (curr-block nil :type comp-block :documentation "Current block baing limplified.") - (sp 0 :type number - :documentation "Current stack pointer while walking LAP.") + (sp -1 :type number + :documentation "Current stack pointer while walking LAP. +Points to the next slot to be filled.") (pc 0 :type number :documentation "Current program counter while walking LAP.") (label-to-addr nil :type hash-table @@ -595,10 +596,10 @@ The block is returned." (defun comp-emit-uncond-jump (lap-label) "Emit an unconditional branch to LAP-LABEL." (cl-destructuring-bind (label-num . stack-depth) lap-label - (cl-assert (= stack-depth (comp-sp))) + (cl-assert (= (1- stack-depth) (comp-sp))) (let ((target (comp-lap-to-limple-bb label-num))) (comp-block-maybe-mark-pending :name target - :sp stack-depth + :sp (comp-sp) :addr (comp-label-to-addr label-num)) (comp-emit `(jump ,target))))) @@ -609,9 +610,10 @@ block. If NEGATED non null negate the tested condition. Return value is the fall through block name." (cl-destructuring-bind (label-num . target-sp) lap-label - (cl-assert (= target-sp (+ target-offset (comp-sp)))) - (let ((bb (comp-new-block-sym)) ; Fall through block. + (let ((target-sp (1- target-sp)) + (bb (comp-new-block-sym)) ; Fall through block. (target (comp-lap-to-limple-bb label-num))) + (cl-assert (= target-sp (+ target-offset (comp-sp)))) (comp-block-maybe-mark-pending :name bb :sp (comp-sp) :addr (1+ (comp-limplify-pc comp-pass))) @@ -772,7 +774,7 @@ the annotation emission." (comp-op-case (TAG ;; Paranoically sanity check stack depth. - (cl-assert (= (cddr insn) (comp-limplify-sp comp-pass)))) + (cl-assert (= (1- (cddr insn)) (comp-limplify-sp comp-pass)))) (byte-stack-ref (comp-copy-slot (- (comp-sp) arg 1))) (byte-varref @@ -1054,8 +1056,8 @@ The block name is returned." (pcase next-inst (`(TAG ,_label . ,target-sp) (when fall-through - (cl-assert (= target-sp (comp-sp)))) - (let ((next-bb (comp-add-pending-block target-sp))) + (cl-assert (= (1- target-sp) (comp-sp)))) + (let ((next-bb (comp-add-pending-block (1- target-sp)))) (when fall-through (comp-emit `(jump ,next-bb)))) (return))) commit 661567b7cd8092e1b41346b77e97201ea4d2efc2 Author: Andrea Corallo Date: Sat Oct 19 18:15:00 2019 +0200 remove comp-stack-adjust diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index f99f42462c..95fbe9f2de 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -642,10 +642,6 @@ Return value is the fall through block name." handler-bb guarded-bb))))) -(defun comp-stack-adjust (n) - "Move sp by N." - (cl-incf (comp-sp) n)) - (defun comp-limplify-listn (n) "Limplify list N." (comp-with-sp (+ (comp-sp) n -1) @@ -760,7 +756,7 @@ the annotation emission." ,(concat "LAP op " op-name))) ;; Emit the stack adjustment if present. ,(when (and sp-delta (not (eq 0 sp-delta))) - `(comp-stack-adjust ,sp-delta)) + `(cl-incf (comp-sp) ,sp-delta)) ,@(comp-body-eff body op-name sp-delta)) else collect `(',op (error ,(concat "Unsupported LAP op " @@ -791,7 +787,7 @@ the annotation emission." (make-comp-mvar :constant arg) (comp-slot+1)))) (byte-call - (comp-stack-adjust (- arg)) + (cl-incf (comp-sp) (- arg)) (comp-emit-set-call (comp-callref 'funcall (1+ arg) (comp-sp)))) (byte-unbind (comp-emit (comp-call 'helper_unbind_n @@ -945,20 +941,20 @@ the annotation emission." (byte-numberp auto) (byte-integerp auto) (byte-listN - (comp-stack-adjust (- 1 arg)) + (cl-incf (comp-sp) (- 1 arg)) (comp-emit-set-call (comp-callref 'list arg (comp-sp)))) (byte-concatN - (comp-stack-adjust (- 1 arg)) + (cl-incf (comp-sp) (- 1 arg)) (comp-emit-set-call (comp-callref 'concat arg (comp-sp)))) (byte-insertN - (comp-stack-adjust (- 1 arg)) + (cl-incf (comp-sp) (- 1 arg)) (comp-emit-set-call (comp-callref 'insert arg (comp-sp)))) (byte-stack-set (comp-with-sp (1+ (comp-sp)) ;; FIXME!! (comp-copy-slot (comp-sp) (- (comp-sp) arg)))) (byte-stack-set2 (cl-assert nil)) ;; TODO (byte-discardN - (comp-stack-adjust (- arg))) + (cl-incf (comp-sp) (- arg))) (byte-switch ;; Assume to follow the emission of a setimm. ;; This is checked into comp-emit-switch. @@ -968,7 +964,7 @@ the annotation emission." (byte-constant (comp-emit-set-const arg)) (byte-discardN-preserve-tos - (comp-stack-adjust (- arg)) + (cl-incf (comp-sp) (- arg)) (comp-copy-slot (+ arg (comp-sp))))))) (defun comp-emit-narg-prologue (minarg nonrest) commit f0e83548ee9d08a558363f73d6ec8e6f30e1cab0 Author: Andrea Corallo Date: Sat Oct 19 16:31:02 2019 +0200 re enable switch support diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 8782fd9fac..f99f42462c 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -453,7 +453,8 @@ If INPUT is a string this is the file path to be compiled." (defconst comp-lap-eob-ops '(byte-goto byte-goto-if-nil byte-goto-if-not-nil byte-goto-if-nil-else-pop - byte-goto-if-not-nil-else-pop byte-return byte-pushcatch) + byte-goto-if-not-nil-else-pop byte-return byte-pushcatch + byte-switch) "LAP end of basic blocks op codes.") (defsubst comp-lap-eob-p (inst) @@ -462,8 +463,7 @@ If INPUT is a string this is the file path to be compiled." t)) (defsubst comp-lap-fall-through-p (inst) - "Return t if INST fall through. -nil otherwise." + "Return t if INST fall through, nil otherwise." (when (not (member (car inst) '(byte-goto byte-return))) t)) @@ -570,17 +570,28 @@ If DST-N is specified use it otherwise assume it to be the current slot." (cl-assert (numberp rel-idx)) (comp-emit `(setimm ,(comp-slot) ,rel-idx ,val)))) -(defun comp-make-curr-block (block-name entry-sp) +(defun comp-make-curr-block (block-name entry-sp &optional addr) "Create a basic block with BLOCK-NAME and set it as current block. ENTRY-SP is the sp value when entering. The block is added to the current function. The block is returned." - (let ((bb (make--comp-block :name block-name :sp entry-sp))) + (let ((bb (make--comp-block :name block-name :sp entry-sp :addr addr))) (setf (comp-limplify-curr-block comp-pass) bb) + (setf (comp-limplify-pc comp-pass) addr) (setf (comp-limplify-sp comp-pass) (comp-block-sp bb)) (puthash (comp-block-name bb) bb (comp-func-blocks comp-func)) bb)) +(defun comp-lap-to-limple-bb (n) + "Given the LAP label N return the limple basic block name." + (let ((hash (comp-func-lap-block comp-func))) + (if-let ((bb (gethash n hash))) + ;; If was already created return it. + bb + (let ((name (comp-new-block-sym))) + (puthash n name hash) + name)))) + (defun comp-emit-uncond-jump (lap-label) "Emit an unconditional branch to LAP-LABEL." (cl-destructuring-bind (label-num . stack-depth) lap-label @@ -595,7 +606,8 @@ The block is returned." "Emit a conditional jump to LAP-LABEL when A and B satisfy EQ. TARGET-OFFSET is the positive offset on the SP when branching to the target block. -If NEGATED non null negate the tested condition." +If NEGATED non null negate the tested condition. +Return value is the fall through block name." (cl-destructuring-bind (label-num . target-sp) lap-label (cl-assert (= target-sp (+ target-offset (comp-sp)))) (let ((bb (comp-new-block-sym)) ; Fall through block. @@ -608,7 +620,8 @@ If NEGATED non null negate the tested condition." :addr (comp-label-to-addr label-num)) (comp-emit (if negated (list 'cond-jump a b target bb) - (list 'cond-jump a b bb target)))))) + (list 'cond-jump a b bb target))) + bb))) (defun comp-emit-handler (lap-label handler-type) "Emit a non local exit handler to LAP-LABEL of type HANDLER-TYPE." @@ -649,16 +662,6 @@ If NEGATED non null negate the tested condition." "Return a unique symbol naming the next new basic block." (intern (format "bb_%s" (funcall (comp-func-block-cnt-gen comp-func))))) -(defun comp-lap-to-limple-bb (n) - "Given the LAP label N return the limple basic block name." - (let ((hash (comp-func-lap-block comp-func))) - (if-let ((bb (gethash n hash))) - ;; If was already created return it. - bb - (let ((name (comp-new-block-sym))) - (puthash n name hash) - name)))) - (defun comp-fill-label-h () "Fill label-to-addr hash table for the current function." (setf (comp-limplify-label-to-addr comp-pass) (make-hash-table :test 'eql)) @@ -674,8 +677,24 @@ If NEGATED non null negate the tested condition." (`(setimm ,_ ,_ ,const) (cl-loop for test being each hash-keys of const using (hash-value target-label) + with len = (hash-table-count const) + for n from 1 + for last = (= n len) for m-test = (make-comp-mvar :constant test) - do (comp-emit-cond-jump var m-test 0 target-label nil))) + for ff-bb = (comp-new-block-sym) ; Fall through block. + for target = (comp-lap-to-limple-bb target-label) + do + (comp-emit (list 'cond-jump var m-test ff-bb target)) + (comp-block-maybe-mark-pending :name target + :sp (comp-sp) + :addr (comp-label-to-addr target-label)) + (if last + (comp-block-maybe-mark-pending :name ff-bb + :sp (comp-sp) + :addr (1+ (comp-limplify-pc comp-pass))) + (comp-make-curr-block ff-bb + (comp-sp) + (comp-limplify-pc comp-pass))))) (_ (error "Missing previous setimm while creating a switch")))) (defun comp-emit-set-call-subr (subr-name sp-delta) @@ -1012,36 +1031,39 @@ This will be called at load-time." when (pred bb) do (return (comp-block-name bb)))))) +(defun comp-add-pending-block (sp) + "Add next basic block to the pending queue. +The block name is returned." + (let ((next-bb (or (comp-addr-to-bb-name (comp-limplify-pc comp-pass)) + (comp-new-block-sym)))) + (comp-block-maybe-mark-pending :name next-bb + :sp sp + :addr (comp-limplify-pc comp-pass)) + next-bb)) + (defun comp-limplify-block (bb) "Limplify basic-block BB and add it to the current function." - (cl-flet ((add-next-block (sp ff) - ;; Maybe create next block. Emit a jump to it if FF. - (let ((next-bb (or (comp-addr-to-bb-name (comp-limplify-pc comp-pass)) - (comp-new-block-sym)))) - (comp-block-maybe-mark-pending :name next-bb - :sp sp - :addr (comp-limplify-pc comp-pass)) - (when ff - (comp-emit `(jump ,next-bb)))))) - (setf (comp-limplify-curr-block comp-pass) bb) - (setf (comp-limplify-sp comp-pass) (comp-block-sp bb)) - (setf (comp-limplify-pc comp-pass) (comp-block-addr bb)) - (cl-loop - for inst-cell on (nthcdr (comp-limplify-pc comp-pass) - (comp-func-lap comp-func)) - for inst = (car inst-cell) - for next-inst = (car-safe (cdr inst-cell)) - for fall-through = (comp-lap-fall-through-p inst) - do (comp-limplify-lap-inst inst) - (cl-incf (comp-limplify-pc comp-pass)) - (pcase next-inst - (`(TAG ,_label . ,target-sp) + (setf (comp-limplify-curr-block comp-pass) bb) + (setf (comp-limplify-sp comp-pass) (comp-block-sp bb)) + (setf (comp-limplify-pc comp-pass) (comp-block-addr bb)) + (puthash (comp-block-name bb) bb (comp-func-blocks comp-func)) + (cl-loop + for inst-cell on (nthcdr (comp-limplify-pc comp-pass) + (comp-func-lap comp-func)) + for inst = (car inst-cell) + for next-inst = (car-safe (cdr inst-cell)) + for fall-through = (comp-lap-fall-through-p inst) + do (comp-limplify-lap-inst inst) + (cl-incf (comp-limplify-pc comp-pass)) + (pcase next-inst + (`(TAG ,_label . ,target-sp) + (when fall-through + (cl-assert (= target-sp (comp-sp)))) + (let ((next-bb (comp-add-pending-block target-sp))) (when fall-through - (cl-assert (= target-sp (comp-sp)))) - (add-next-block target-sp fall-through) - (return))) - until (comp-lap-eob-p inst)) - (puthash (comp-block-name bb) bb (comp-func-blocks comp-func)))) + (comp-emit `(jump ,next-bb)))) + (return))) + until (comp-lap-eob-p inst))) (defun comp-limplify-function (func) "Limplify a single function FUNC." commit 1a4aa391eea22fc053aa40c1827c7726de5fa7ac Author: Andrea Corallo Date: Sat Oct 19 11:20:15 2019 +0200 reworking comp-limplify-block diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 1d14289b46..8782fd9fac 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -461,6 +461,12 @@ If INPUT is a string this is the file path to be compiled." (when (member (car inst) comp-lap-eob-ops) t)) +(defsubst comp-lap-fall-through-p (inst) + "Return t if INST fall through. +nil otherwise." + (when (not (member (car inst) '(byte-goto byte-return))) + t)) + (defsubst comp-sp () "Current stack pointer." (comp-limplify-sp comp-pass)) @@ -498,7 +504,7 @@ Restore the original value afterwards." (cl-defun comp-block-maybe-mark-pending (&rest args &key name sp &allow-other-keys) "Create a basic block and mark it as pending." (if-let ((bb (gethash name (comp-func-blocks comp-func)))) - ;; If was already limplified sanity check sp. + ;; If was already declared sanity check sp. (cl-assert (or (null sp) (= sp (comp-block-sp bb))) (sp (comp-block-sp bb)) "sp %d %d differs") ;; Mark it pending in case is not already. @@ -590,15 +596,15 @@ The block is returned." TARGET-OFFSET is the positive offset on the SP when branching to the target block. If NEGATED non null negate the tested condition." - (cl-destructuring-bind (label-num . stack-depth) lap-label - (cl-assert (= stack-depth (+ target-offset (comp-sp)))) + (cl-destructuring-bind (label-num . target-sp) lap-label + (cl-assert (= target-sp (+ target-offset (comp-sp)))) (let ((bb (comp-new-block-sym)) ; Fall through block. (target (comp-lap-to-limple-bb label-num))) (comp-block-maybe-mark-pending :name bb - :sp stack-depth + :sp (comp-sp) :addr (1+ (comp-limplify-pc comp-pass))) (comp-block-maybe-mark-pending :name target - :sp (+ target-offset stack-depth) + :sp target-sp :addr (comp-label-to-addr label-num)) (comp-emit (if negated (list 'cond-jump a b target bb) @@ -1008,27 +1014,34 @@ This will be called at load-time." (defun comp-limplify-block (bb) "Limplify basic-block BB and add it to the current function." - (setf (comp-limplify-curr-block comp-pass) bb) - (setf (comp-limplify-sp comp-pass) (comp-block-sp bb)) - (setf (comp-limplify-pc comp-pass) (comp-block-addr bb)) - (cl-loop - for inst-cell on (nthcdr (comp-limplify-pc comp-pass) - (comp-func-lap comp-func)) - for inst = (car inst-cell) - for next-inst = (car-safe (cdr inst-cell)) - do (comp-limplify-lap-inst inst) - (cl-incf (comp-limplify-pc comp-pass)) - when (eq (car next-inst) 'TAG) - do ; That's a fall through. - (let ((bb (or (comp-addr-to-bb-name (comp-limplify-pc comp-pass)) - (comp-new-block-sym)))) - (comp-block-maybe-mark-pending :name bb - :sp (comp-sp) - :addr (comp-limplify-pc comp-pass)) - (comp-emit `(jump ,bb))) - and return nil - until (comp-lap-eob-p inst)) - (puthash (comp-block-name bb) bb (comp-func-blocks comp-func))) + (cl-flet ((add-next-block (sp ff) + ;; Maybe create next block. Emit a jump to it if FF. + (let ((next-bb (or (comp-addr-to-bb-name (comp-limplify-pc comp-pass)) + (comp-new-block-sym)))) + (comp-block-maybe-mark-pending :name next-bb + :sp sp + :addr (comp-limplify-pc comp-pass)) + (when ff + (comp-emit `(jump ,next-bb)))))) + (setf (comp-limplify-curr-block comp-pass) bb) + (setf (comp-limplify-sp comp-pass) (comp-block-sp bb)) + (setf (comp-limplify-pc comp-pass) (comp-block-addr bb)) + (cl-loop + for inst-cell on (nthcdr (comp-limplify-pc comp-pass) + (comp-func-lap comp-func)) + for inst = (car inst-cell) + for next-inst = (car-safe (cdr inst-cell)) + for fall-through = (comp-lap-fall-through-p inst) + do (comp-limplify-lap-inst inst) + (cl-incf (comp-limplify-pc comp-pass)) + (pcase next-inst + (`(TAG ,_label . ,target-sp) + (when fall-through + (cl-assert (= target-sp (comp-sp)))) + (add-next-block target-sp fall-through) + (return))) + until (comp-lap-eob-p inst)) + (puthash (comp-block-name bb) bb (comp-func-blocks comp-func)))) (defun comp-limplify-function (func) "Limplify a single function FUNC." @@ -1231,7 +1244,7 @@ Top level forms for the current context are rendered too." (cl-loop for insn in (comp-block-insns bb) when (and (comp-assign-op-p (car insn)) (= slot-n (comp-mvar-slot (cadr insn)))) - return t))) + return t))) (cl-loop for i from 0 below (comp-func-frame-size comp-func) ;; List of blocks with a definition of mvar i commit 3b58bac273b517844210c9ecd07757625dc9804d Author: Andrea Corallo Date: Mon Oct 14 22:08:24 2019 +0200 mega loop refactor diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 8baad18e97..1d14289b46 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -314,9 +314,8 @@ BODY is evaluate only if `comp-verbose' is > 0." (comp-log (format "\nFunction: %s" (comp-func-symbol-name func))) (cl-loop for block-name being each hash-keys of (comp-func-blocks func) using (hash-value bb) - do (progn - (comp-log (concat "<" (symbol-name block-name) ">\n")) - (comp-log (comp-block-insns bb))))) + do (comp-log (concat "<" (symbol-name block-name) ">\n")) + (comp-log (comp-block-insns bb)))) (defun comp-log-edges (func) "Log edges in FUNC." @@ -346,7 +345,7 @@ Put PREFIX in front of it." for i across orig-name for byte = (format "%x" i) do (aset str j (aref byte 0)) - do (aset str (1+ j) (aref byte 1)) + (aset str (1+ j) (aref byte 1)) finally return str)) (human-readable (replace-regexp-in-string "-" "_" orig-name)) @@ -950,17 +949,15 @@ the annotation emission." (defun comp-emit-narg-prologue (minarg nonrest) "Emit the prologue for a narg function." (cl-loop for i below minarg - do (progn - (comp-emit `(set-args-to-local ,(comp-slot-n i))) - (comp-emit '(inc-args)))) + do (comp-emit `(set-args-to-local ,(comp-slot-n i))) + (comp-emit '(inc-args))) (cl-loop for i from minarg below nonrest for bb = (intern (format "entry_%s" i)) for fallback = (intern (format "entry_fallback_%s" i)) - do (progn - (comp-emit `(cond-jump-narg-leq ,i ,bb ,fallback)) - (comp-make-curr-block bb (comp-sp)) - (comp-emit `(set-args-to-local ,(comp-slot-n i))) - (comp-emit '(inc-args))) + do (comp-emit `(cond-jump-narg-leq ,i ,bb ,fallback)) + (comp-make-curr-block bb (comp-sp)) + (comp-emit `(set-args-to-local ,(comp-slot-n i))) + (comp-emit '(inc-args)) finally (comp-emit '(jump entry_rest_args))) (cl-loop for i from minarg below nonrest do (comp-with-sp i @@ -1019,9 +1016,8 @@ This will be called at load-time." (comp-func-lap comp-func)) for inst = (car inst-cell) for next-inst = (car-safe (cdr inst-cell)) - do (progn - (comp-limplify-lap-inst inst) - (cl-incf (comp-limplify-pc comp-pass))) + do (comp-limplify-lap-inst inst) + (cl-incf (comp-limplify-pc comp-pass)) when (eq (car next-inst) 'TAG) do ; That's a fall through. (let ((bb (or (comp-addr-to-bb-name (comp-limplify-pc comp-pass)) @@ -1050,7 +1046,7 @@ This will be called at load-time." (if (comp-args-p args) (cl-loop for i below (comp-args-max args) do (cl-incf (comp-sp)) - do (comp-emit `(set-par-to-local ,(comp-slot) ,i))) + (comp-emit `(set-par-to-local ,(comp-slot) ,i))) (let ((nonrest (comp-nargs-nonrest args))) (comp-emit-narg-prologue args-min nonrest) (cl-incf (comp-sp) (1+ nonrest)))) @@ -1128,7 +1124,7 @@ Top level forms for the current context are rendered too." (cl-loop for edge in (comp-func-edges comp-func) do (push edge (comp-block-out-edges (comp-edge-src edge))) - do (push edge + (push edge (comp-block-in-edges (comp-edge-dst edge)))) (comp-log-edges comp-func))))) @@ -1193,9 +1189,8 @@ Top level forms for the current context are rendered too." when (comp-block-dom p) do (setf new-idom (intersect p new-idom))) unless (eq (comp-block-dom b) new-idom) - do (progn - (setf (comp-block-dom b) new-idom) - (setf changed t))))))) + do (setf (comp-block-dom b) new-idom) + (setf changed t)))))) (defun comp-compute-dominator-frontiers () ;; Originally based on: "A Simple, Fast Dominance Algorithm" @@ -1236,7 +1231,7 @@ Top level forms for the current context are rendered too." (cl-loop for insn in (comp-block-insns bb) when (and (comp-assign-op-p (car insn)) (= slot-n (comp-mvar-slot (cadr insn)))) - do (cl-return t)))) + return t))) (cl-loop for i from 0 below (comp-func-frame-size comp-func) ;; List of blocks with a definition of mvar i @@ -1253,13 +1248,12 @@ Top level forms for the current context are rendered too." (let ((x (pop w))) (cl-loop for y being each hash-value of (comp-block-df x) unless (cl-find y f) - do (progn - (add-phi i y) - (push y f) - ;; Adding a phi implies mentioning the - ;; corresponding slot so in case adjust w. - (unless (cl-find y defs-v) - (push y w))))))))) + do (add-phi i y) + (push y f) + ;; Adding a phi implies mentioning the + ;; corresponding slot so in case adjust w. + (unless (cl-find y defs-v) + (push y w)))))))) (defun comp-dom-tree-walker (bb pre-lambda post-lambda) "Dominator tree walker function starting from basic block BB. @@ -1551,8 +1545,7 @@ This can run just once." for (op arg0 . rest) = insn if (comp-set-op-p op) do (push (comp-mvar-id arg0) l-vals) - and - do (setf r-vals (nconc (comp-collect-mvar-ids rest) r-vals)) + (setf r-vals (nconc (comp-collect-mvar-ids rest) r-vals)) else do (setf r-vals (nconc (comp-collect-mvar-ids insn) r-vals)))) ;; Every l-value appearing that does not appear as r-value has no right to @@ -1571,11 +1564,11 @@ This can run just once." for (op arg0 rest) = insn when (and (comp-set-op-p op) (member (comp-mvar-id arg0) nuke-list)) - do (setcar insn-cell - (if (comp-limple-insn-call-p rest) - rest - `(comment ,(format "optimized out: %s" - insn))))))))) + do (setcar insn-cell + (if (comp-limple-insn-call-p rest) + rest + `(comment ,(format "optimized out: %s" + insn))))))))) (defun comp-remove-type-hints-func () "Remove type hints from the current function. commit 26db0a032640a107bb0155b2f1eb7a586dbd8985 Author: Andrea Corallo Date: Sun Oct 13 20:45:14 2019 +0200 make stack depth computation robust in limplify diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index fd37d1645a..8baad18e97 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -578,28 +578,51 @@ The block is returned." (defun comp-emit-uncond-jump (lap-label) "Emit an unconditional branch to LAP-LABEL." - (let ((target (comp-lap-to-limple-bb lap-label))) - (comp-block-maybe-mark-pending :name target - :sp (comp-sp) - :addr (comp-label-to-addr lap-label)) - (comp-emit `(jump ,target)))) + (cl-destructuring-bind (label-num . stack-depth) lap-label + (cl-assert (= stack-depth (comp-sp))) + (let ((target (comp-lap-to-limple-bb label-num))) + (comp-block-maybe-mark-pending :name target + :sp stack-depth + :addr (comp-label-to-addr label-num)) + (comp-emit `(jump ,target))))) (defun comp-emit-cond-jump (a b target-offset lap-label negated) "Emit a conditional jump to LAP-LABEL when A and B satisfy EQ. TARGET-OFFSET is the positive offset on the SP when branching to the target block. -If NEGATED non nil negate the tested condition." - (let ((bb (comp-new-block-sym)) ; Fall through block. - (target (comp-lap-to-limple-bb lap-label))) - (comp-block-maybe-mark-pending :name bb - :sp (comp-sp) - :addr (1+ (comp-limplify-pc comp-pass))) - (comp-block-maybe-mark-pending :name target - :sp (+ target-offset (comp-sp)) - :addr (comp-label-to-addr lap-label)) - (comp-emit (if negated - (list 'cond-jump a b target bb) - (list 'cond-jump a b bb target))))) +If NEGATED non null negate the tested condition." + (cl-destructuring-bind (label-num . stack-depth) lap-label + (cl-assert (= stack-depth (+ target-offset (comp-sp)))) + (let ((bb (comp-new-block-sym)) ; Fall through block. + (target (comp-lap-to-limple-bb label-num))) + (comp-block-maybe-mark-pending :name bb + :sp stack-depth + :addr (1+ (comp-limplify-pc comp-pass))) + (comp-block-maybe-mark-pending :name target + :sp (+ target-offset stack-depth) + :addr (comp-label-to-addr label-num)) + (comp-emit (if negated + (list 'cond-jump a b target bb) + (list 'cond-jump a b bb target)))))) + +(defun comp-emit-handler (lap-label handler-type) + "Emit a non local exit handler to LAP-LABEL of type HANDLER-TYPE." + (cl-destructuring-bind (label-num . stack-depth) lap-label + (cl-assert (= stack-depth (comp-sp))) + (let ((guarded-bb (comp-new-block-sym)) + (handler-bb (comp-lap-to-limple-bb label-num))) + (comp-block-maybe-mark-pending :name guarded-bb + :sp stack-depth + :addr (1+ (comp-limplify-pc comp-pass))) + (comp-block-maybe-mark-pending :name handler-bb + :sp (1+ stack-depth) + :addr (comp-label-to-addr label-num)) + (comp-emit (list 'push-handler + (comp-slot+1) + (comp-slot+1) + handler-type + handler-bb + guarded-bb))))) (defun comp-stack-adjust (n) "Move sp by N." @@ -640,23 +663,6 @@ If NEGATED non nil negate the tested condition." (`(TAG ,label . ,_) (puthash label addr (comp-limplify-label-to-addr comp-pass)))))) -(defun comp-emit-handler (guarded-label handler-type) - "Emit a non local exit handler to GUARDED-LABEL of type HANDLER-TYPE." - (let ((guarded-bb (comp-new-block-sym)) - (handler-bb (comp-lap-to-limple-bb guarded-label))) - (comp-block-maybe-mark-pending :name guarded-bb - :sp (comp-sp) - :addr (1+ (comp-limplify-pc comp-pass))) - (comp-block-maybe-mark-pending :name handler-bb - :sp (1+ (comp-sp)) - :addr (comp-label-to-addr guarded-label)) - (comp-emit (list 'push-handler - (comp-slot+1) - (comp-slot+1) - handler-type - handler-bb - guarded-bb)))) - (defun comp-emit-switch (var last-insn) "Emit a limple for a lap jump table given VAR and LAST-INSN." (pcase last-insn @@ -769,9 +775,9 @@ the annotation emission." (byte-pophandler (comp-emit '(pop-handler))) (byte-pushconditioncase - (comp-emit-handler (cl-third insn) 'condition-case)) + (comp-emit-handler (cddr insn) 'condition-case)) (byte-pushcatch - (comp-emit-handler (cl-third insn) 'catcher)) + (comp-emit-handler (cddr insn) 'catcher)) (byte-nth auto) (byte-symbolp auto) (byte-consp auto) @@ -862,19 +868,19 @@ the annotation emission." (byte-constant2) ; TODO ;; Branches. (byte-goto - (comp-emit-uncond-jump (cl-third insn))) + (comp-emit-uncond-jump (cddr insn))) (byte-goto-if-nil (comp-emit-cond-jump (comp-slot+1) (make-comp-mvar :constant nil) 0 - (cl-third insn) nil)) + (cddr insn) nil)) (byte-goto-if-not-nil (comp-emit-cond-jump (comp-slot+1) (make-comp-mvar :constant nil) 0 - (cl-third insn) t)) + (cddr insn) t)) (byte-goto-if-nil-else-pop (comp-emit-cond-jump (comp-slot+1) (make-comp-mvar :constant nil) 1 - (cl-third insn) nil)) + (cddr insn) nil)) (byte-goto-if-not-nil-else-pop (comp-emit-cond-jump (comp-slot+1) (make-comp-mvar :constant nil) 1 - (cl-third insn) t)) + (cddr insn) t)) (byte-return (comp-emit `(return ,(comp-slot+1)))) (byte-discard 'pass) commit c6d819ecb5dafddb7b4dffa4c84f5264a3061d53 Author: Andrea Corallo Date: Sun Oct 13 20:22:37 2019 +0200 fix initial stack depth diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index adda0537a6..fd37d1645a 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -983,7 +983,6 @@ This will be called at load-time." (comp-func func) (comp-pass (make-comp-limplify :curr-block (make--comp-block) - :sp -1 :frame (comp-new-frame 0)))) (comp-make-curr-block 'entry (comp-sp)) (comp-emit-annotation "Top level") @@ -1034,7 +1033,6 @@ This will be called at load-time." (let* ((frame-size (comp-func-frame-size func)) (comp-func func) (comp-pass (make-comp-limplify - :sp -1 :frame (comp-new-frame frame-size))) (args (comp-func-args func)) (args-min (comp-args-base-min args))) commit a90803a4d1bc47fcfc3b9a3af519cd8441bd92de Author: Andrea Corallo Date: Sun Oct 13 20:22:14 2019 +0200 add stack sanity check diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index b2eee68b3f..adda0537a6 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -745,7 +745,8 @@ the annotation emission." (cdr insn)))) (comp-op-case (TAG - (comp-lap-to-limple-bb arg)) + ;; Paranoically sanity check stack depth. + (cl-assert (= (cddr insn) (comp-limplify-sp comp-pass)))) (byte-stack-ref (comp-copy-slot (- (comp-sp) arg 1))) (byte-varref commit ca907fe89b16d59b067669f1c43af3eace1509ea Author: Andrea Corallo Date: Sun Oct 13 18:58:46 2019 +0200 fix missing fall through handling diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 06bbc40012..b2eee68b3f 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -454,9 +454,7 @@ If INPUT is a string this is the file path to be compiled." (defconst comp-lap-eob-ops '(byte-goto byte-goto-if-nil byte-goto-if-not-nil byte-goto-if-nil-else-pop - byte-goto-if-not-nil-else-pop byte-return byte-pushcatch - byte-pophandler ; ?? - ) + byte-goto-if-not-nil-else-pop byte-return byte-pushcatch) "LAP end of basic blocks op codes.") (defsubst comp-lap-eob-p (inst) @@ -493,6 +491,11 @@ Restore the original value afterwards." "Slot into the meta-stack pointed by sp + 1." (comp-slot-n (1+ (comp-sp)))) +(defsubst comp-label-to-addr (label) + "Find the address of LABEL." + (or (gethash label (comp-limplify-label-to-addr comp-pass)) + (error "Can't find label %d" label))) + (cl-defun comp-block-maybe-mark-pending (&rest args &key name sp &allow-other-keys) "Create a basic block and mark it as pending." (if-let ((bb (gethash name (comp-func-blocks comp-func)))) @@ -634,14 +637,9 @@ If NEGATED non nil negate the tested condition." (cl-loop for insn in (comp-func-lap comp-func) for addr from 0 do (pcase insn - (`(TAG ,label) + (`(TAG ,label . ,_) (puthash label addr (comp-limplify-label-to-addr comp-pass)))))) -(defsubst comp-label-to-addr (label) - "Find the address of LABEL." - (and (gethash label (comp-limplify-label-to-addr comp-pass)) - (error "Can't find label %d" label))) - (defun comp-emit-handler (guarded-label handler-type) "Emit a non local exit handler to GUARDED-LABEL of type HANDLER-TYPE." (let ((guarded-bb (comp-new-block-sym)) @@ -993,17 +991,41 @@ This will be called at load-time." (comp-emit `(return ,(make-comp-mvar :constant nil))) (comp-limplify-finalize-function func))) +(defun comp-addr-to-bb-name (addr) + "Search for a block starting at ADDR into pending or limplified blocks." + ;; FIXME: Actually we could have another hash for this. + (cl-flet ((pred (bb) + (equal (comp-block-addr bb) addr))) + (if-let ((pending (cl-find-if #'pred + (comp-limplify-pending-blocks comp-pass)))) + (comp-block-name pending) + (cl-loop for bb being the hash-value in (comp-func-blocks comp-func) + when (pred bb) + do (return (comp-block-name bb)))))) + (defun comp-limplify-block (bb) "Limplify basic-block BB and add it to the current function." (setf (comp-limplify-curr-block comp-pass) bb) (setf (comp-limplify-sp comp-pass) (comp-block-sp bb)) (setf (comp-limplify-pc comp-pass) (comp-block-addr bb)) - (cl-loop for inst in (nthcdr (comp-limplify-pc comp-pass) - (comp-func-lap comp-func)) - do (progn - (comp-limplify-lap-inst inst) - (cl-incf (comp-limplify-pc comp-pass))) - until (comp-lap-eob-p inst)) + (cl-loop + for inst-cell on (nthcdr (comp-limplify-pc comp-pass) + (comp-func-lap comp-func)) + for inst = (car inst-cell) + for next-inst = (car-safe (cdr inst-cell)) + do (progn + (comp-limplify-lap-inst inst) + (cl-incf (comp-limplify-pc comp-pass))) + when (eq (car next-inst) 'TAG) + do ; That's a fall through. + (let ((bb (or (comp-addr-to-bb-name (comp-limplify-pc comp-pass)) + (comp-new-block-sym)))) + (comp-block-maybe-mark-pending :name bb + :sp (comp-sp) + :addr (comp-limplify-pc comp-pass)) + (comp-emit `(jump ,bb))) + and return nil + until (comp-lap-eob-p inst)) (puthash (comp-block-name bb) bb (comp-func-blocks comp-func))) (defun comp-limplify-function (func) commit cae7d6cd58868916bcec34d9572736e7541b9710 Author: Andrea Corallo Date: Sun Oct 13 17:41:26 2019 +0200 fix label to addr computation diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 491a0bfc25..06bbc40012 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -102,15 +102,6 @@ Can be used by code that wants to expand differently in this case.") direct-callref) "Limple operators use to call subrs.") -(defconst comp-mostly-pure-funcs - '(% * + - / /= 1+ 1- < <= = > >= cons list % concat logand logcount logior - lognot logxor regexp-opt regexp-quote string-to-char string-to-syntax - symbol-name) - "Functions on witch we do constant propagation." - ;; Is it acceptable to move into the compile time functions that are - ;; allocating memory? (these are technically not side effect free) -) - (eval-when-compile (defconst comp-op-stack-info (cl-loop with h = (make-hash-table) @@ -123,7 +114,7 @@ Can be used by code that wants to expand differently in this case.") (cl-defstruct comp-ctxt "Lisp side of the compiler context." - (output nil :type 'string + (output nil :type string :documentation "Target output filename for the compilation.") (top-level-defvars nil :type list :documentation "List of top level form to be exp.") @@ -456,12 +447,16 @@ If INPUT is a string this is the file path to be compiled." :documentation "Current stack pointer while walking LAP.") (pc 0 :type number :documentation "Current program counter while walking LAP.") + (label-to-addr nil :type hash-table + :documentation "LAP hash table -> address.") (pending-blocks () :type list :documentation "List of blocks waiting for limplification.")) (defconst comp-lap-eob-ops '(byte-goto byte-goto-if-nil byte-goto-if-not-nil byte-goto-if-nil-else-pop - byte-goto-if-not-nil-else-pop byte-return) + byte-goto-if-not-nil-else-pop byte-return byte-pushcatch + byte-pophandler ; ?? + ) "LAP end of basic blocks op codes.") (defsubst comp-lap-eob-p (inst) @@ -498,13 +493,6 @@ Restore the original value afterwards." "Slot into the meta-stack pointed by sp + 1." (comp-slot-n (1+ (comp-sp)))) -(cl-defun comp-block-maybe-add (&rest args &key name sp &allow-other-keys) - (let ((blocks (comp-func-blocks comp-func))) - (if-let ((bb (gethash name blocks))) - ;; Sanity check sp. - (cl-assert (or (null sp) (= sp (comp-block-sp bb)))) - (puthash name (apply #'make--comp-block args) blocks)))) - (cl-defun comp-block-maybe-mark-pending (&rest args &key name sp &allow-other-keys) "Create a basic block and mark it as pending." (if-let ((bb (gethash name (comp-func-blocks comp-func)))) @@ -590,7 +578,7 @@ The block is returned." (let ((target (comp-lap-to-limple-bb lap-label))) (comp-block-maybe-mark-pending :name target :sp (comp-sp) - :addr lap-label) + :addr (comp-label-to-addr lap-label)) (comp-emit `(jump ,target)))) (defun comp-emit-cond-jump (a b target-offset lap-label negated) @@ -605,7 +593,7 @@ If NEGATED non nil negate the tested condition." :addr (1+ (comp-limplify-pc comp-pass))) (comp-block-maybe-mark-pending :name target :sp (+ target-offset (comp-sp)) - :addr lap-label) + :addr (comp-label-to-addr lap-label)) (comp-emit (if negated (list 'cond-jump a b target bb) (list 'cond-jump a b bb target))))) @@ -640,18 +628,36 @@ If NEGATED non nil negate the tested condition." (puthash n name hash) name)))) +(defun comp-fill-label-h () + "Fill label-to-addr hash table for the current function." + (setf (comp-limplify-label-to-addr comp-pass) (make-hash-table :test 'eql)) + (cl-loop for insn in (comp-func-lap comp-func) + for addr from 0 + do (pcase insn + (`(TAG ,label) + (puthash label addr (comp-limplify-label-to-addr comp-pass)))))) + +(defsubst comp-label-to-addr (label) + "Find the address of LABEL." + (and (gethash label (comp-limplify-label-to-addr comp-pass)) + (error "Can't find label %d" label))) + (defun comp-emit-handler (guarded-label handler-type) - "Emit a non local exit handler for GUARDED-LABEL of type HANDLER-TYPE." - (let ((guarded-bb (comp-new-block-sym))) - (comp-block-maybe-add :name guarded-bb :sp (comp-sp)) - (let ((handler-bb (comp-lap-to-limple-bb guarded-label))) - (comp-emit (list 'push-handler - (comp-slot+1) - (comp-slot+1) - handler-type - handler-bb - guarded-bb)) - (comp-block-maybe-add :name handler-bb :sp (1+ (comp-sp)))))) + "Emit a non local exit handler to GUARDED-LABEL of type HANDLER-TYPE." + (let ((guarded-bb (comp-new-block-sym)) + (handler-bb (comp-lap-to-limple-bb guarded-label))) + (comp-block-maybe-mark-pending :name guarded-bb + :sp (comp-sp) + :addr (1+ (comp-limplify-pc comp-pass))) + (comp-block-maybe-mark-pending :name handler-bb + :sp (1+ (comp-sp)) + :addr (comp-label-to-addr guarded-label)) + (comp-emit (list 'push-handler + (comp-slot+1) + (comp-slot+1) + handler-type + handler-bb + guarded-bb)))) (defun comp-emit-switch (var last-insn) "Emit a limple for a lap jump table given VAR and LAST-INSN." @@ -1009,6 +1015,7 @@ This will be called at load-time." :frame (comp-new-frame frame-size))) (args (comp-func-args func)) (args-min (comp-args-base-min args))) + (comp-fill-label-h) ;; Prologue (comp-make-curr-block 'entry (comp-sp)) (comp-emit-annotation (concat "Lisp function: " commit 6bbbf3fd829f5000acb63536b5019b5be62d3e66 Author: Andrea Corallo Date: Sun Oct 13 10:36:22 2019 +0200 reworking limplify diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index b9203ca780..491a0bfc25 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -160,11 +160,11 @@ To be used when ncall-conv is nil.")) "A basic block." (name nil :type symbol) ;; These two slots are used during limplification. - (sp nil + (sp nil :type number :documentation "When non nil indicates the sp value while entering into it.") - (closed nil :type boolean - :documentation "If the block was already closed.") + (addr nil :type number + :documentation "Start block LAP address.") (insns () :type list :documentation "List of instructions.") ;; All the followings are for SSA and CGF analysis. @@ -228,7 +228,6 @@ structure.") (defun comp-func-reset-generators (func) "Reset unique id generators for FUNC." - ;; (setf (block-cnt-gen func) (comp-gen-counter)) (setf (comp-func-edge-cnt-gen func) (comp-gen-counter)) (setf (comp-func-ssa-cnt-gen func) (comp-gen-counter))) @@ -251,7 +250,6 @@ structure.") (defvar comp-ctxt) ;; FIXME (to be removed) ;; Special vars used by some passes -(defvar comp-block) ; Can probably be removed (defvar comp-func) @@ -450,12 +448,26 @@ If INPUT is a string this is the file path to be compiled." (cl-defstruct (comp-limplify (:copier nil)) "Support structure used during function limplification." - (sp 0 :type fixnum - :documentation "Current stack pointer while walking LAP.") (frame nil :type vector :documentation "Meta-stack used to flat LAP.") - (block-name nil :type symbol - :documentation "Current basic block name.")) + (curr-block nil :type comp-block + :documentation "Current block baing limplified.") + (sp 0 :type number + :documentation "Current stack pointer while walking LAP.") + (pc 0 :type number + :documentation "Current program counter while walking LAP.") + (pending-blocks () :type list + :documentation "List of blocks waiting for limplification.")) + +(defconst comp-lap-eob-ops + '(byte-goto byte-goto-if-nil byte-goto-if-not-nil byte-goto-if-nil-else-pop + byte-goto-if-not-nil-else-pop byte-return) + "LAP end of basic blocks op codes.") + +(defsubst comp-lap-eob-p (inst) + "Return t if INST closes the current basic blocks, nil otherwise." + (when (member (car inst) comp-lap-eob-ops) + t)) (defsubst comp-sp () "Current stack pointer." @@ -489,13 +501,23 @@ Restore the original value afterwards." (cl-defun comp-block-maybe-add (&rest args &key name sp &allow-other-keys) (let ((blocks (comp-func-blocks comp-func))) (if-let ((bb (gethash name blocks))) - (if-let ((bb-sp (comp-block-sp bb))) - ;; If was a sp was already registered sanity check it. - (cl-assert (or (null sp) (= sp bb-sp))) - ;; Otherwise set it. - (setf (comp-block-sp bb) sp)) + ;; Sanity check sp. + (cl-assert (or (null sp) (= sp (comp-block-sp bb)))) (puthash name (apply #'make--comp-block args) blocks)))) +(cl-defun comp-block-maybe-mark-pending (&rest args &key name sp &allow-other-keys) + "Create a basic block and mark it as pending." + (if-let ((bb (gethash name (comp-func-blocks comp-func)))) + ;; If was already limplified sanity check sp. + (cl-assert (or (null sp) (= sp (comp-block-sp bb))) + (sp (comp-block-sp bb)) "sp %d %d differs") + ;; Mark it pending in case is not already. + (unless (cl-find-if (lambda (bb) + (eq (comp-block-name bb) name)) + (comp-limplify-pending-blocks comp-pass)) + (push (apply #'make--comp-block args) + (comp-limplify-pending-blocks comp-pass))))) + (defun comp-call (func &rest args) "Emit a call for function FUNC with ARGS." (comp-add-subr-to-relocs func) @@ -524,10 +546,9 @@ Restore the original value afterwards." do (aset v i mvar) finally (return v))) -(defun comp-emit (insn) +(defsubst comp-emit (insn) "Emit INSN into current basic block." - (cl-assert (not (comp-block-closed comp-block))) - (push insn (comp-block-insns comp-block))) + (push insn (comp-block-insns (comp-limplify-curr-block comp-pass)))) (defun comp-emit-set-call (call) "Emit CALL assigning the result the the current slot frame. @@ -553,53 +574,41 @@ If DST-N is specified use it otherwise assume it to be the current slot." (cl-assert (numberp rel-idx)) (comp-emit `(setimm ,(comp-slot) ,rel-idx ,val)))) -(defun comp-mark-block-closed () - "Mark current basic block as closed." - (setf (comp-block-closed (gethash (comp-limplify-block-name comp-pass) - (comp-func-blocks comp-func))) - t)) - -(defun comp-emit-jump (target) - "Emit an unconditional branch to block TARGET." - (comp-emit (list 'jump target)) - (comp-mark-block-closed)) - -(defun comp-emit-block (block-name &optional entry-sp) - "Emit basic block BLOCK-NAME. -ENTRY-SP is the sp value when entering." - (let ((blocks (comp-func-blocks comp-func))) - ;; In case does not exist register it into comp-func-blocks. - (comp-block-maybe-add :name block-name - :sp entry-sp) - ;; If we are abandoning an non closed basic block close it with a fall - ;; through. - (when (and (not (eq block-name 'entry)) - (not (comp-block-closed - (gethash (comp-limplify-block-name comp-pass) - blocks)))) - (comp-emit-jump block-name)) - ;; Set this a currently compiled block. - (setf comp-block (gethash block-name blocks)) - ;; If we are landing here from a previously recorded branch with known sp - ;; adjust accordingly. - (when-let ((new-sp (comp-block-sp (gethash block-name blocks)))) - (setf (comp-sp) new-sp)) - (setf (comp-limplify-block-name comp-pass) block-name))) +(defun comp-make-curr-block (block-name entry-sp) + "Create a basic block with BLOCK-NAME and set it as current block. +ENTRY-SP is the sp value when entering. +The block is added to the current function. +The block is returned." + (let ((bb (make--comp-block :name block-name :sp entry-sp))) + (setf (comp-limplify-curr-block comp-pass) bb) + (setf (comp-limplify-sp comp-pass) (comp-block-sp bb)) + (puthash (comp-block-name bb) bb (comp-func-blocks comp-func)) + bb)) + +(defun comp-emit-uncond-jump (lap-label) + "Emit an unconditional branch to LAP-LABEL." + (let ((target (comp-lap-to-limple-bb lap-label))) + (comp-block-maybe-mark-pending :name target + :sp (comp-sp) + :addr lap-label) + (comp-emit `(jump ,target)))) (defun comp-emit-cond-jump (a b target-offset lap-label negated) "Emit a conditional jump to LAP-LABEL when A and B satisfy EQ. TARGET-OFFSET is the positive offset on the SP when branching to the target block. If NEGATED non nil negate the tested condition." - (let ((bb (comp-new-block-sym))) ;; Fall through block - (comp-block-maybe-add :name bb :sp (comp-sp)) - (let ((target (comp-lap-to-limple-bb lap-label))) - (comp-emit (if negated - (list 'cond-jump a b target bb) - (list 'cond-jump a b bb target))) - (comp-block-maybe-add :name target :sp (+ target-offset (comp-sp))) - (comp-mark-block-closed)) - (comp-emit-block bb (comp-sp)))) + (let ((bb (comp-new-block-sym)) ; Fall through block. + (target (comp-lap-to-limple-bb lap-label))) + (comp-block-maybe-mark-pending :name bb + :sp (comp-sp) + :addr (1+ (comp-limplify-pc comp-pass))) + (comp-block-maybe-mark-pending :name target + :sp (+ target-offset (comp-sp)) + :addr lap-label) + (comp-emit (if negated + (list 'cond-jump a b target bb) + (list 'cond-jump a b bb target))))) (defun comp-stack-adjust (n) "Move sp by N." @@ -642,9 +651,7 @@ If NEGATED non nil negate the tested condition." handler-type handler-bb guarded-bb)) - (comp-block-maybe-add :name handler-bb :sp (1+ (comp-sp))) - (comp-mark-block-closed) - (comp-emit-block guarded-bb (comp-sp))))) + (comp-block-maybe-add :name handler-bb :sp (1+ (comp-sp)))))) (defun comp-emit-switch (var last-insn) "Emit a limple for a lap jump table given VAR and LAST-INSN." @@ -734,7 +741,7 @@ the annotation emission." (cdr insn)))) (comp-op-case (TAG - (comp-emit-block (comp-lap-to-limple-bb arg))) + (comp-lap-to-limple-bb arg)) (byte-stack-ref (comp-copy-slot (- (comp-sp) arg 1))) (byte-varref @@ -847,9 +854,10 @@ the annotation emission." (byte-widen (comp-emit-set-call (comp-call 'widen))) (byte-end-of-line auto) - (byte-constant2) ;; TODO + (byte-constant2) ; TODO + ;; Branches. (byte-goto - (comp-emit-jump (comp-lap-to-limple-bb (cl-third insn)))) + (comp-emit-uncond-jump (cl-third insn))) (byte-goto-if-nil (comp-emit-cond-jump (comp-slot+1) (make-comp-mvar :constant nil) 0 (cl-third insn) nil)) @@ -863,8 +871,7 @@ the annotation emission." (comp-emit-cond-jump (comp-slot+1) (make-comp-mvar :constant nil) 1 (cl-third insn) t)) (byte-return - (comp-emit `(return ,(comp-slot+1))) - (comp-mark-block-closed)) + (comp-emit `(return ,(comp-slot+1)))) (byte-discard 'pass) (byte-dup (comp-copy-slot (1- (comp-sp)))) @@ -920,7 +927,9 @@ the annotation emission." (byte-switch ;; Assume to follow the emission of a setimm. ;; This is checked into comp-emit-switch. - (comp-emit-switch (comp-slot+1) (cl-second (comp-block-insns comp-block)))) + (comp-emit-switch (comp-slot+1) + (cl-second (comp-block-insns + (comp-limplify-curr-block comp-pass))))) (byte-constant (comp-emit-set-const arg)) (byte-discardN-preserve-tos @@ -938,17 +947,16 @@ the annotation emission." for fallback = (intern (format "entry_fallback_%s" i)) do (progn (comp-emit `(cond-jump-narg-leq ,i ,bb ,fallback)) - (comp-mark-block-closed) - (comp-emit-block bb (comp-sp)) + (comp-make-curr-block bb (comp-sp)) (comp-emit `(set-args-to-local ,(comp-slot-n i))) (comp-emit '(inc-args))) - finally (comp-emit-jump 'entry_rest_args)) + finally (comp-emit '(jump entry_rest_args))) (cl-loop for i from minarg below nonrest do (comp-with-sp i - (comp-emit-block (intern (format "entry_fallback_%s" i)) - (comp-sp)) + (comp-make-curr-block (intern (format "entry_fallback_%s" i)) + (comp-sp)) (comp-emit-set-const nil))) - (comp-emit-block 'entry_rest_args (comp-sp)) + (comp-make-curr-block 'entry_rest_args (comp-sp)) (comp-emit `(set-rest-args-to-local ,(comp-slot-n nonrest)))) (defun comp-limplify-finalize-function (func) @@ -969,16 +977,29 @@ This will be called at load-time." :frame-size 0)) (comp-func func) (comp-pass (make-comp-limplify + :curr-block (make--comp-block) :sp -1 - :frame (comp-new-frame 0))) - (comp-block ())) - (comp-emit-block 'entry (comp-sp)) + :frame (comp-new-frame 0)))) + (comp-make-curr-block 'entry (comp-sp)) (comp-emit-annotation "Top level") (cl-loop for args in (comp-ctxt-top-level-defvars comp-ctxt) do (comp-emit (comp-call 'defvar (make-comp-mvar :constant args)))) (comp-emit `(return ,(make-comp-mvar :constant nil))) (comp-limplify-finalize-function func))) +(defun comp-limplify-block (bb) + "Limplify basic-block BB and add it to the current function." + (setf (comp-limplify-curr-block comp-pass) bb) + (setf (comp-limplify-sp comp-pass) (comp-block-sp bb)) + (setf (comp-limplify-pc comp-pass) (comp-block-addr bb)) + (cl-loop for inst in (nthcdr (comp-limplify-pc comp-pass) + (comp-func-lap comp-func)) + do (progn + (comp-limplify-lap-inst inst) + (cl-incf (comp-limplify-pc comp-pass))) + until (comp-lap-eob-p inst)) + (puthash (comp-block-name bb) bb (comp-func-blocks comp-func))) + (defun comp-limplify-function (func) "Limplify a single function FUNC." (let* ((frame-size (comp-func-frame-size func)) @@ -987,10 +1008,9 @@ This will be called at load-time." :sp -1 :frame (comp-new-frame frame-size))) (args (comp-func-args func)) - (args-min (comp-args-base-min args)) - (comp-block ())) + (args-min (comp-args-base-min args))) ;; Prologue - (comp-emit-block 'entry (comp-sp)) + (comp-make-curr-block 'entry (comp-sp)) (comp-emit-annotation (concat "Lisp function: " (symbol-name (comp-func-symbol-name func)))) (if (comp-args-p args) @@ -1000,9 +1020,14 @@ This will be called at load-time." (let ((nonrest (comp-nargs-nonrest args))) (comp-emit-narg-prologue args-min nonrest) (cl-incf (comp-sp) (1+ nonrest)))) + (comp-emit '(jump bb_0)) ;; Body - (comp-emit-block (comp-new-block-sym) (comp-sp)) - (mapc #'comp-limplify-lap-inst (comp-func-lap func)) + (comp-block-maybe-mark-pending :name (comp-new-block-sym) + :sp (comp-sp) + :addr 0) + (cl-loop for next-bb = (pop (comp-limplify-pending-blocks comp-pass)) + while next-bb + do (comp-limplify-block next-bb)) (comp-limplify-finalize-function func))) (defun comp-add-func-to-ctxt (func) commit 01334409d6b03ef101bfd5cc8f5589220fa16483 Author: Andrea Corallo Date: Sat Oct 5 17:51:49 2019 +0200 doc fix diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index e706756d8c..b9203ca780 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -962,7 +962,7 @@ the annotation emission." (defun comp-limplify-top-level () "Create a limple function doing the business for top level forms. -This will be called at runtime." +This will be called at load-time." (let* ((func (make-comp-func :symbol-name 'top-level-run :c-func-name "top_level_run" :args (make-comp-args :min 0 :max 0) commit f69a2b851d80602a158f8878811a63b219eb7fc4 Author: Andrea Corallo Date: Sat Oct 5 17:08:48 2019 +0200 remove unnecessary macros into limplify pass diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 349db10991..e706756d8c 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -29,6 +29,7 @@ ;;; Code: (require 'bytecomp) +(require 'gv) (require 'cl-lib) (require 'cl-extra) (require 'subr-x) @@ -447,9 +448,20 @@ If INPUT is a string this is the file path to be compiled." ;;; Limplification pass specific code. -(defmacro comp-sp () +(cl-defstruct (comp-limplify (:copier nil)) + "Support structure used during function limplification." + (sp 0 :type fixnum + :documentation "Current stack pointer while walking LAP.") + (frame nil :type vector + :documentation "Meta-stack used to flat LAP.") + (block-name nil :type symbol + :documentation "Current basic block name.")) + +(defsubst comp-sp () "Current stack pointer." - '(comp-limplify-sp comp-pass)) + (comp-limplify-sp comp-pass)) +(gv-define-setter comp-sp (value) + `(setf (comp-limplify-sp comp-pass) ,value)) (defmacro comp-with-sp (sp &rest body) "Execute BODY setting the stack pointer to SP. @@ -462,27 +474,17 @@ Restore the original value afterwards." (progn ,@body) (setf (comp-sp) ,sym)))) -(defmacro comp-slot-n (n) +(defsubst comp-slot-n (n) "Slot N into the meta-stack." - (declare (debug (form))) - `(aref (comp-limplify-frame comp-pass) ,n)) + (aref (comp-limplify-frame comp-pass) n)) -(defmacro comp-slot () +(defsubst comp-slot () "Current slot into the meta-stack pointed by sp." - '(comp-slot-n (comp-sp))) + (comp-slot-n (comp-sp))) -(defmacro comp-slot+1 () +(defsubst comp-slot+1 () "Slot into the meta-stack pointed by sp + 1." - '(comp-slot-n (1+ (comp-sp)))) - -(cl-defstruct (comp-limplify (:copier nil)) - "Support structure used during function limplification." - (sp 0 :type fixnum - :documentation "Current stack pointer while walking LAP.") - (frame nil :type vector - :documentation "Meta-stack used to flat LAP.") - (block-name nil :type symbol - :documentation "Current basic block name.")) + (comp-slot-n (1+ (comp-sp)))) (cl-defun comp-block-maybe-add (&rest args &key name sp &allow-other-keys) (let ((blocks (comp-func-blocks comp-func))) commit 4a00e47d4d75528ec69291c03615bd669c58ed7e Author: Andrea Corallo Date: Sat Oct 5 16:26:52 2019 +0200 fix comp.el compilation warning diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index a026ba9b2b..349db10991 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1450,7 +1450,7 @@ This can run just once." (`(callref funcall ,f . ,rest) (when-let ((new-form (comp-call-optim-form-call (comp-mvar-constant f) rest self))) - (setcar insn-cell ,new-form))))))) + (setcar insn-cell new-form))))))) (defun comp-call-optim (_) "Given FUNCS try to avoid funcall trampoline usage when possible." commit 4a526ab48d10a26c9f58bde504023dd83017b088 Author: Andrea Corallo Date: Sat Oct 5 16:20:57 2019 +0200 remove nasty nested macro usage in limplify pass diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 2822760c89..a026ba9b2b 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -533,31 +533,6 @@ If the callee function is known to have a return type propagate it." (cl-assert call) (comp-emit (list 'set (comp-slot) call))) -(defmacro comp-emit-set-call-subr (subr-name sp-delta) - "Emit a call for SUBR-NAME. -SP-DELTA is the stack adjustment." - (let ((subr (symbol-function subr-name)) - (subr-str (symbol-name subr-name)) - (nargs (1+ (- sp-delta)))) - (cl-assert (subrp subr) nil - "%s not a subr" subr-str) - (let* ((arity (subr-arity subr)) - (minarg (car arity)) - (maxarg (cdr arity))) - (cl-assert (not (eq maxarg 'unevalled)) nil - "%s contains unevalled arg" subr-name) - (if (eq maxarg 'many) - ;; callref case. - `(comp-emit-set-call (comp-callref ',subr-name ,nargs (comp-sp))) - ;; Normal call. - (cl-assert (and (>= maxarg nargs) (<= minarg nargs)) - (nargs maxarg minarg) - "Incoherent stack adjustment %d, maxarg %d minarg %d") - `(let* ((subr-name ',subr-name) - (slots (cl-loop for i from 0 below ,maxarg - collect (comp-slot-n (+ i (comp-sp)))))) - (comp-emit-set-call (apply #'comp-call (cons subr-name slots)))))))) - (defun comp-copy-slot (src-n &optional dst-n) "Set slot number DST-N to slot number SRC-N as source. If DST-N is specified use it otherwise assume it to be the current slot." @@ -679,47 +654,75 @@ If NEGATED non nil negate the tested condition." do (comp-emit-cond-jump var m-test 0 target-label nil))) (_ (error "Missing previous setimm while creating a switch")))) +(defun comp-emit-set-call-subr (subr-name sp-delta) + "Emit a call for SUBR-NAME. +SP-DELTA is the stack adjustment." + (let ((subr (symbol-function subr-name)) + (subr-str (symbol-name subr-name)) + (nargs (1+ (- sp-delta)))) + (cl-assert (subrp subr) nil + "%s not a subr" subr-str) + (let* ((arity (subr-arity subr)) + (minarg (car arity)) + (maxarg (cdr arity))) + (cl-assert (not (eq maxarg 'unevalled)) nil + "%s contains unevalled arg" subr-name) + (if (eq maxarg 'many) + ;; callref case. + (comp-emit-set-call (comp-callref subr-name nargs (comp-sp))) + ;; Normal call. + (cl-assert (and (>= maxarg nargs) (<= minarg nargs)) + (nargs maxarg minarg) + "Incoherent stack adjustment %d, maxarg %d minarg %d") + (let* ((subr-name subr-name) + (slots (cl-loop for i from 0 below maxarg + collect (comp-slot-n (+ i (comp-sp)))))) + (comp-emit-set-call (apply #'comp-call (cons subr-name slots)))))))) + +(eval-when-compile + (defun comp-op-to-fun (x) + "Given the LAP op strip \"byte-\" to have the subr name." + (intern (replace-regexp-in-string "byte-" "" x))) + + (defun comp-body-eff (body op-name sp-delta) + "Given the original body BODY compute the effective one. +When BODY is auto guess function name form the LAP bytecode +name. Othewise expect lname fnname." + (pcase (car body) + ('auto + (list `(comp-emit-set-call-subr + ',(comp-op-to-fun op-name) + ,sp-delta))) + ((pred symbolp) + (list `(comp-emit-set-call-subr + ',(car body) + ,sp-delta))) + (_ body)))) + (defmacro comp-op-case (&rest cases) "Expand CASES into the corresponding pcase. This is responsible for generating the proper stack adjustment when known and the annotation emission." (declare (debug (body)) (indent defun)) - (cl-labels ((op-to-fun (x) - ;; Given the LAP op strip "byte-" to have the subr name. - (intern (replace-regexp-in-string "byte-" "" x))) - (body-eff (body op-name sp-delta) - ;; Given the original body BODY compute the effective one. - ;; When BODY is auto guess function name form the LAP bytecode - ;; name. Othewise expect lname fnname. - (pcase (car body) - ('auto - (list `(comp-emit-set-call-subr - ,(op-to-fun op-name) - ,sp-delta))) - ((pred symbolp) - (list `(comp-emit-set-call-subr - ,(car body) - ,sp-delta))) - (_ body)))) - `(pcase op - ,@(cl-loop for (op . body) in cases - for sp-delta = (gethash op comp-op-stack-info) - for op-name = (symbol-name op) - if body - collect `(',op - ;; Log all LAP ops except the TAG one. - ,(unless (eq op 'TAG) - `(comp-emit-annotation - ,(concat "LAP op " op-name))) - ;; Emit the stack adjustment if present. - ,(when (and sp-delta (not (eq 0 sp-delta))) - `(comp-stack-adjust ,sp-delta)) - ,@(body-eff body op-name sp-delta)) - else - collect `(',op (error ,(concat "Unsupported LAP op " - op-name)))) - (_ (error "Unexpected LAP op %s" (symbol-name op)))))) + `(pcase op + ,@(cl-loop for (op . body) in cases + for sp-delta = (gethash op comp-op-stack-info) + for op-name = (symbol-name op) + if body + collect `(',op + ;; Log all LAP ops except the TAG one. + ,(unless (eq op 'TAG) + `(comp-emit-annotation + ,(concat "LAP op " op-name))) + ;; Emit the stack adjustment if present. + ,(when (and sp-delta (not (eq 0 sp-delta))) + `(comp-stack-adjust ,sp-delta)) + ,@(comp-body-eff body op-name sp-delta)) + else + collect `(',op (error ,(concat "Unsupported LAP op " + op-name)))) + (_ (error "Unexpected LAP op %s" (symbol-name op))))) (defun comp-limplify-lap-inst (insn) "Limplify LAP instruction INSN pushng it in the proper basic block." commit 4cc1374786dcc28b80da546e708f7360f102abd4 Author: Andrea Corallo Date: Sat Oct 5 16:05:37 2019 +0200 add comp-test-silly-frame2 to test funcs diff --git a/test/src/comp-test-funcs.el b/test/src/comp-test-funcs.el index 3d8d3437bd..540170ea96 100644 --- a/test/src/comp-test-funcs.el +++ b/test/src/comp-test-funcs.el @@ -340,8 +340,8 @@ ;; Non tested functions that proved just to be difficult to compile. -(defun comp-test-callee (_ _) t) -(defun comp-test-silly-frame (x) +(defun comp-test-callee (_ __) t) +(defun comp-test-silly-frame1 (x) (cl-case x (0 (comp-test-callee (pcase comp-tests-var1 @@ -349,4 +349,10 @@ (2 2)) 3)))) +(defun comp-test-silly-frame2 (token) + (while c + (cl-case c + (?< 1) + (?> 2)))) + ;;; comp-test-funcs.el ends here commit f8a454f3efa10d59b8228b5c1373bfc9fb8ed718 Author: Andrea Corallo Date: Sat Oct 5 15:05:07 2019 +0200 clean-up commented code diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 25e5be2851..2822760c89 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -494,13 +494,6 @@ Restore the original value afterwards." (setf (comp-block-sp bb) sp)) (puthash name (apply #'make--comp-block args) blocks)))) -;; (defun comp-opt-call (inst) -;; "Optimize if possible a side-effect-free call in INST." -;; (cl-destructuring-bind (_ f &rest args) inst -;; (when (and (member f comp-mostly-pure-funcs) -;; (cl-every #'identity (mapcar #'comp-mvar-const-vld args))) -;; (apply f (mapcar #'comp-mvar-constant args))))) - (defun comp-call (func &rest args) "Emit a call for function FUNC with ARGS." (comp-add-subr-to-relocs func) commit 63078fb5af152934c5aa5facc5afd7f8e1907ade Author: Andrea Corallo Date: Sun Sep 29 21:43:57 2019 +0200 fix frame size computation diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 3f8482b5d0..25e5be2851 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -378,6 +378,12 @@ Put PREFIX in front of it." (make-comp-nargs :min mandatory :nonrest nonrest)))) +(defun comp-byte-frame-size (byte-compiled-func) + "Given BYTE-COMPILED-FUNC return the frame size to be allocated." + ;; Is this really correct? + ;; For the 1+ see bytecode.c:365 (finger crossed). + (1+ (aref byte-compiled-func 3))) + (defun comp-spill-lap-function (function-name) "Byte compile FUNCTION-NAME spilling data from the byte compiler." (let* ((f (symbol-function function-name)) @@ -396,7 +402,8 @@ Put PREFIX in front of it." (setf (comp-func-args func) (comp-decrypt-lambda-list lambda-list))) (setf (comp-func-lap func) lap) - (setf (comp-func-frame-size func) (aref (comp-func-byte-func func) 3)) + (setf (comp-func-frame-size func) + (comp-byte-frame-size (comp-func-byte-func func))) func))) (defun comp-spill-lap-functions-file (filename) @@ -418,7 +425,8 @@ Put PREFIX in front of it." "F") :args (comp-decrypt-lambda-list lambda-list) :lap lap - :frame-size (aref bytecode 3)) + :frame-size (comp-byte-frame-size + bytecode)) do (when (> comp-verbose 1) (comp-log (format "Function %s:\n" name)) (comp-log lap)) commit 0cbe9c204e938977fef12dd4cc47d43a702ebfa9 Author: Andrea Corallo Date: Sat Oct 5 14:51:56 2019 +0200 add comp-test-silly-frame to tests diff --git a/test/src/comp-test-funcs.el b/test/src/comp-test-funcs.el index e43db6973b..3d8d3437bd 100644 --- a/test/src/comp-test-funcs.el +++ b/test/src/comp-test-funcs.el @@ -338,4 +338,15 @@ (setq comp-test-up-val 24)) (setq comp-test-up-val 999))) +;; Non tested functions that proved just to be difficult to compile. + +(defun comp-test-callee (_ _) t) +(defun comp-test-silly-frame (x) + (cl-case x + (0 (comp-test-callee + (pcase comp-tests-var1 + (1 1) + (2 2)) + 3)))) + ;;; comp-test-funcs.el ends here commit 0ae14c17a24545dacf8ed309b2a75f8f1ed7da5c Author: Andrea Corallo Date: Sat Oct 5 14:48:15 2019 +0200 fix compilation of devar defconst with doc string diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 1666dff711..72e5835020 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -2276,7 +2276,7 @@ we output that argument and the following argument QUOTED says that we have to put a quote before the list that represents a doc string reference. `defvaralias', `autoload' and `custom-declare-variable' need that." - (when byte-native-compiling + (when (and byte-native-compiling name) ;; Spill bytecode output for the native compiler here (push (cons name (apply #'vector form)) byte-to-native-bytecode)) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 584a02af0e..3f8482b5d0 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -408,7 +408,7 @@ Put PREFIX in front of it." ('defvar (cdr x)) ('defconst (cdr x)))) byte-to-native-top-level-forms))) - (cl-loop for (name . bytecode) in (remove-if-not #'car byte-to-native-bytecode) + (cl-loop for (name . bytecode) in byte-to-native-bytecode for lap = (alist-get name byte-to-native-lap) for lambda-list = (aref bytecode 0) for func = (make-comp-func :symbol-name name commit 65c0d931f79672e15c6dfd633b619eabfbe9183a Author: Andrea Corallo Date: Thu Oct 3 22:15:43 2019 +0200 alist-get instead of assoc cdr diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 9f808d2704..584a02af0e 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -389,7 +389,7 @@ Put PREFIX in front of it." (error "Can't native compile an already bytecompiled function")) (setf (comp-func-byte-func func) (byte-compile (comp-func-symbol-name func))) - (let ((lap (cdr (assoc function-name (reverse byte-to-native-bytecode))))) + (let ((lap (alist-get function-name (reverse byte-to-native-bytecode)))) (cl-assert lap) (comp-log lap) (let ((lambda-list (aref (comp-func-byte-func func) 0))) @@ -409,7 +409,7 @@ Put PREFIX in front of it." ('defconst (cdr x)))) byte-to-native-top-level-forms))) (cl-loop for (name . bytecode) in (remove-if-not #'car byte-to-native-bytecode) - for lap = (cdr (assoc name byte-to-native-lap)) + for lap = (alist-get name byte-to-native-lap) for lambda-list = (aref bytecode 0) for func = (make-comp-func :symbol-name name :byte-func bytecode @@ -1330,12 +1330,12 @@ This can run just once." (pcase rval (`(,(or 'call 'direct-call) ,f . ,_) (setf (comp-mvar-type lval) - (cdr (assq f comp-known-ret-types)))) + (alist-get f comp-known-ret-types))) (`(,(or 'callref 'direct-callref) ,f . ,args) (cl-loop for v in args do (setf (comp-mvar-ref v) t)) (setf (comp-mvar-type lval) - (cdr (assq f comp-known-ret-types)))) + (alist-get f comp-known-ret-types))) (_ (comp-mvar-propagate lval rval)))) (`(phi ,lval . ,rest) commit 1f91b8c6eedc12fce03e76ebf8b9c039c5a0a0b4 Author: Andrea Corallo Date: Mon Sep 30 17:13:07 2019 +0200 better immediate type propagation diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 796c130efa..9f808d2704 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1298,16 +1298,25 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non nil." ;;; propagate pass specific code. ;; A very basic propagation pass follows. +(defsubst comp-strict-type-of (obj) + "Given OBJ return its type understanding fixnums." + ;; Should be certainly smarter but now we take advantages just from fixnums. + (if (fixnump obj) + 'fixnum + (type-of obj))) + (defun comp-basic-const-propagate () "Propagate simple constants for setimm operands. This can run just once." - (cl-loop for b being each hash-value of (comp-func-blocks comp-func) - do (cl-loop for insn in (comp-block-insns b) - do (pcase insn - (`(setimm ,lval ,_ ,v) - (setf (comp-mvar-const-vld lval) t) - (setf (comp-mvar-constant lval) v) - (setf (comp-mvar-type lval) (type-of v))))))) + (cl-loop + for b being each hash-value of (comp-func-blocks comp-func) + do (cl-loop + for insn in (comp-block-insns b) + do (pcase insn + (`(setimm ,lval ,_ ,v) + (setf (comp-mvar-const-vld lval) t) + (setf (comp-mvar-constant lval) v) + (setf (comp-mvar-type lval) (comp-strict-type-of v))))))) (defsubst comp-mvar-propagate (lval rval) "Propagate into LVAL properties of RVAL." commit abac70f198fc6502e3b4d81f9d9590e9d7432378 Author: Andrea Corallo Date: Mon Sep 30 17:04:49 2019 +0200 ignore anonymous forms (they are not functions) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index cd1a6b2e93..796c130efa 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -408,11 +408,8 @@ Put PREFIX in front of it." ('defvar (cdr x)) ('defconst (cdr x)))) byte-to-native-top-level-forms))) - ;; Hacky! We need to reverse `byte-to-native-lap' to have the compiled top - ;; level form that matters (ex exclude lambdas)... - (cl-loop with lap-funcs = byte-to-native-lap - for (name . bytecode) in byte-to-native-bytecode - for lap = (cdr (assoc name lap-funcs)) + (cl-loop for (name . bytecode) in (remove-if-not #'car byte-to-native-bytecode) + for lap = (cdr (assoc name byte-to-native-lap)) for lambda-list = (aref bytecode 0) for func = (make-comp-func :symbol-name name :byte-func bytecode commit 9ff098615f92cf9fe4aa0f1c6835dbf9198daa6c Author: Andrea Corallo Date: Mon Sep 30 04:43:01 2019 +0200 remove INLINE hints from comp.c diff --git a/src/comp.c b/src/comp.c index 2ab9d034eb..039daeeaad 100644 --- a/src/comp.c +++ b/src/comp.c @@ -230,7 +230,7 @@ bcall0 (Lisp_Object f) Ffuncall (1, &f); } -INLINE static gcc_jit_field * +static gcc_jit_field * type_to_cast_field (gcc_jit_type *type) { gcc_jit_field *field; @@ -419,7 +419,7 @@ emit_call_ref (Lisp_Object subr_sym, unsigned nargs, /* Close current basic block emitting a conditional. */ -INLINE static void +static void emit_cond_jump (gcc_jit_rvalue *test, gcc_jit_block *then_target, gcc_jit_block *else_target) { @@ -506,7 +506,7 @@ emit_ptr_arithmetic (gcc_jit_rvalue *ptr, gcc_jit_type *ptr_type, offset)); } -INLINE static gcc_jit_rvalue * +static gcc_jit_rvalue * emit_XLI (gcc_jit_rvalue *obj) { emit_comment ("XLI"); @@ -516,7 +516,7 @@ emit_XLI (gcc_jit_rvalue *obj) comp.lisp_obj_as_num); } -INLINE static gcc_jit_lvalue * +static gcc_jit_lvalue * emit_lval_XLI (gcc_jit_lvalue *obj) { emit_comment ("lval_XLI"); @@ -526,7 +526,7 @@ emit_lval_XLI (gcc_jit_lvalue *obj) comp.lisp_obj_as_num); } -INLINE static gcc_jit_rvalue * +static gcc_jit_rvalue * emit_XLP (gcc_jit_rvalue *obj) { emit_comment ("XLP"); @@ -536,7 +536,7 @@ emit_XLP (gcc_jit_rvalue *obj) comp.lisp_obj_as_ptr); } -INLINE static gcc_jit_lvalue * +static gcc_jit_lvalue * emit_lval_XLP (gcc_jit_lvalue *obj) { emit_comment ("lval_XLP"); commit d19bb4861553fe82b86ef09db6cb6b1fe1eae829 Author: Andrea Corallo Date: Sun Sep 29 19:58:09 2019 +0200 fix missing direct parameter forwarding into emit_limple_call_ref diff --git a/src/comp.c b/src/comp.c index 15699a0211..2ab9d034eb 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1145,7 +1145,7 @@ emit_limple_call_ref (Lisp_Object insn, bool direct) Lisp_Object callee = FIRST (insn); EMACS_UINT nargs = XFIXNUM (Flength (CDR (insn))); EMACS_UINT base_ptr = XFIXNUM (FUNCALL1 (comp-mvar-slot, SECOND (insn))); - return emit_call_ref (callee, nargs, comp.frame[base_ptr], false); + return emit_call_ref (callee, nargs, comp.frame[base_ptr], direct); } /* Register an handler for a non local exit. */ commit b8127e988e2af662bdcd7cf25d281469a5142df6 Author: Andrea Corallo Date: Sun Sep 29 19:31:19 2019 +0200 remove unnecessary autostirng usage diff --git a/src/comp.c b/src/comp.c index f55aa8191e..15699a0211 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3047,23 +3047,19 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, define_add1_sub1 (); define_negate (); - /* Compile all functions. Can't be done before because the - relocation structs has to be already defined. */ struct Lisp_Hash_Table *func_h = XHASH_TABLE (FUNCALL1 (comp-ctxt-funcs-h, Vcomp_ctxt)); for (ptrdiff_t i = 0; i < func_h->count; i++) declare_function (HASH_VALUE (func_h, i)); + /* Compile all functions. Can't be done before because the + relocation structs has to be already defined. */ for (ptrdiff_t i = 0; i < func_h->count; i++) compile_function (HASH_VALUE (func_h, i)); - /* FIXME use format_string here */ if (COMP_DEBUG) - { - AUTO_STRING (dot_c, ".c"); - const char *filename = - (const char *) SDATA (CALLN (Fconcat, ctxtname, dot_c)); - gcc_jit_context_dump_to_file (comp.ctxt, filename, 1); - } + gcc_jit_context_dump_to_file (comp.ctxt, + format_string ("%s.c", SSDATA (ctxtname)), + 1); if (COMP_DEBUG > 1) gcc_jit_context_dump_reproducer_to_file (comp.ctxt, "comp_reproducer.c"); commit bf253dd2e9e41a14b813692828ffc43ed24391ae Author: Andrea Corallo Date: Sun Sep 29 18:41:31 2019 +0200 regulate verbosity with comp-verbose diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index ef602c1381..cd1a6b2e93 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -37,8 +37,12 @@ "Emacs Lisp native compiler." :group 'lisp) -(defcustom comp-verbose 1 - "Compiler verbosity. From 0 to 3." +(defcustom comp-verbose 0 + "Compiler verbosity. From 0 to 3. +- 0 no logging +- 1 final limple is logged +- 2 LAP and final limple are logged +- 3 all passes are dumping" :type 'number :group 'comp) @@ -317,7 +321,7 @@ BODY is evaluate only if `comp-verbose' is > 0." (defun comp-log-func (func) "Log function FUNC." - (comp-log (format "\n Function: %s" (comp-func-symbol-name func))) + (comp-log (format "\nFunction: %s" (comp-func-symbol-name func))) (cl-loop for block-name being each hash-keys of (comp-func-blocks func) using (hash-value bb) do (progn @@ -327,12 +331,15 @@ BODY is evaluate only if `comp-verbose' is > 0." (defun comp-log-edges (func) "Log edges in FUNC." (let ((edges (comp-func-edges func))) - (comp-log (format "\nEdges in function: %s\n" (comp-func-symbol-name func))) + (when (> comp-verbose 2) + (comp-log (format "\nEdges in function: %s\n" + (comp-func-symbol-name func)))) (mapc (lambda (e) - (comp-log (format "n: %d src: %s dst: %s\n" - (comp-edge-number e) - (comp-block-name (comp-edge-src e)) - (comp-block-name (comp-edge-dst e))))) + (when (> comp-verbose 2) + (comp-log (format "n: %d src: %s dst: %s\n" + (comp-edge-number e) + (comp-block-name (comp-edge-src e)) + (comp-block-name (comp-edge-dst e)))))) edges))) @@ -415,7 +422,7 @@ Put PREFIX in front of it." :args (comp-decrypt-lambda-list lambda-list) :lap lap :frame-size (aref bytecode 3)) - do (progn + do (when (> comp-verbose 1) (comp-log (format "Function %s:\n" name)) (comp-log lap)) collect func)) @@ -946,7 +953,8 @@ the annotation emission." (cl-loop for bb being the hash-value in (comp-func-blocks func) do (setf (comp-block-insns bb) (nreverse (comp-block-insns bb)))) - (comp-log-func func) + (when (> comp-verbose 2) + (comp-log-func func)) func) (defun comp-limplify-top-level () @@ -1105,7 +1113,8 @@ Top level forms for the current context are rendered too." with changed = t while changed initially (progn - (comp-log "Computing dominator tree...\n") + (when (> comp-verbose 2) + (comp-log "Computing dominator tree...\n")) (setf (comp-block-dom entry) entry) ;; Set the post order number. (cl-loop for name in (reverse rev-bb-list) @@ -1145,11 +1154,12 @@ Top level forms for the current context are rendered too." (maphash (lambda (name bb) (let ((dom (comp-block-dom bb)) (df (comp-block-df bb))) - (comp-log (format "block: %s idom: %s DF %s\n" - name - (when dom (comp-block-name dom)) - (cl-loop for b being each hash-keys of df - collect b))))) + (when (> comp-verbose 2) + (comp-log (format "block: %s idom: %s DF %s\n" + name + (when dom (comp-block-name dom)) + (cl-loop for b being each hash-keys of df + collect b)))))) (comp-func-blocks comp-func))) (defun comp-place-phis () @@ -1233,7 +1243,8 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non nil." (defun comp-ssa-rename () "Entry point to rename SSA within the current function." - (comp-log "Renaming\n") + (when (> comp-verbose 2) + (comp-log "Renaming\n")) (let ((frame-size (comp-func-frame-size comp-func)) (visited (make-hash-table))) (cl-labels ((ssa-rename-rec (bb in-frame) @@ -1282,7 +1293,8 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non nil." (comp-place-phis) (comp-ssa-rename) (comp-finalize-phis) - (comp-log-func comp-func))) + (when (> comp-verbose 2) + (comp-log-func comp-func)))) (comp-ctxt-funcs-h comp-ctxt))) @@ -1346,7 +1358,8 @@ This can run just once." ;; FIXME: unbelievably dumb... (cl-loop repeat 10 do (comp-propagate*)) - (comp-log-func comp-func))) + (when (> comp-verbose 2) + (comp-log-func comp-func)))) (comp-ctxt-funcs-h comp-ctxt))) @@ -1474,10 +1487,11 @@ This can run just once." ;; Every l-value appearing that does not appear as r-value has no right to ;; exist and gets nuked. (let ((nuke-list (cl-set-difference l-vals r-vals))) - (comp-log (format "Function %s\n" (comp-func-symbol-name comp-func))) - (comp-log (format "l-vals %s\n" l-vals)) - (comp-log (format "r-vals %s\n" r-vals)) - (comp-log (format "Nuking ids: %s\n" nuke-list)) + (when (> comp-verbose 2) + (comp-log (format "Function %s\n" (comp-func-symbol-name comp-func))) + (comp-log (format "l-vals %s\n" l-vals)) + (comp-log (format "r-vals %s\n" r-vals)) + (comp-log (format "Nuking ids: %s\n" nuke-list))) (cl-loop for b being each hash-value of (comp-func-blocks comp-func) do (cl-loop commit de1f89c202427a8bcb783f0b44fd02326b320a65 Author: Andrea Corallo Date: Sun Sep 29 17:54:10 2019 +0200 remove comp-debug diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 5f312e860f..ef602c1381 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -37,9 +37,9 @@ "Emacs Lisp native compiler." :group 'lisp) -(defcustom comp-debug t - "Log compilation process." - :type 'boolean +(defcustom comp-verbose 1 + "Compiler verbosity. From 0 to 3." + :type 'number :group 'comp) (defconst native-compile-log-buffer "*Native-compile-Log*" @@ -49,8 +49,6 @@ "This gets bound to t while native compilation. Can be used by code that wants to expand differently in this case.") -(defvar comp-verbose nil) - (defvar comp-pass nil "Every pass has the right to bind what it likes here.") @@ -290,10 +288,10 @@ The corresponding index is returned." (defmacro comp-within-log-buff (&rest body) "Execute BODY while at the end the log-buffer. -BODY is evaluate only if `comp-debug' is non nil." +BODY is evaluate only if `comp-verbose' is > 0." (declare (debug (form body)) (indent defun)) - `(when comp-debug + `(when (> comp-verbose 0) (with-current-buffer (get-buffer-create native-compile-log-buffer) (setq buffer-read-only t) (let ((inhibit-read-only t)) @@ -303,7 +301,7 @@ BODY is evaluate only if `comp-debug' is non nil." (defun comp-log (data) "Log DATA." (if (and noninteractive - comp-verbose) + (> comp-verbose 0)) (if (atom data) (message "%s" data) (mapc (lambda (x) commit 734eb8f940c197e4b3548e7b79d716203e37aa8d Author: Andrea Corallo Date: Sun Sep 29 14:36:09 2019 +0200 remove defvar that is not anymore necessary diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index cb88bd8852..5f312e860f 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -49,8 +49,6 @@ "This gets bound to t while native compilation. Can be used by code that wants to expand differently in this case.") -;; FIXME these has to be removed -(defvar comp-speed 2) (defvar comp-verbose nil) (defvar comp-pass nil commit 8f1670b40fc9a779303207710a913b769170e82a Author: Andrea Corallo Date: Sun Sep 29 14:32:02 2019 +0200 don't crash when trying to format a very long string diff --git a/src/comp.c b/src/comp.c index 48ddba7eb2..f55aa8191e 100644 --- a/src/comp.c +++ b/src/comp.c @@ -205,7 +205,11 @@ format_string (const char *format, ...) va_start (va, format); int res = vsnprintf (scratch_area, sizeof (scratch_area), format, va); if (res >= sizeof (scratch_area)) - error ("Truncating string"); + { + scratch_area[sizeof (scratch_area) - 4] = '.'; + scratch_area[sizeof (scratch_area) - 3] = '.'; + scratch_area[sizeof (scratch_area) - 2] = '.'; + } va_end (va); return scratch_area; } @@ -302,7 +306,7 @@ register_emitter (Lisp_Object key, void *func) Fputhash (key, value, comp.emitter_dispatcher); } -INLINE static void +static void emit_comment (const char *str) { if (COMP_DEBUG) commit 9da698575addc4b9c007d7d6c1590bc5ac245bdc Author: Andrea Corallo Date: Sun Sep 29 11:05:54 2019 +0200 always expand file name when bytecompiling diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 209c4e68b6..cb88bd8852 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1579,9 +1579,10 @@ If INPUT is a string, use it as the file path to be native compiled." (error "Trying to native compile something not a symbol function or file")) (let ((data input) (comp-native-compiling t) - (comp-ctxt (make-comp-ctxt :output (if (symbolp input) - (symbol-name input) - (file-name-sans-extension input))))) + (comp-ctxt (make-comp-ctxt + :output (if (symbolp input) + (symbol-name input) + (file-name-sans-extension (expand-file-name input)))))) (mapc (lambda (pass) (comp-log (format "Running pass %s:\n" pass)) (setq data (funcall pass data))) commit 7d3da0a37edd57f6a31dff4864bcf1753de48698 Author: Andrea Corallo Date: Thu Sep 26 12:11:13 2019 +0200 fix subr-native-elisp-p predicate name diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 13bc3de5ac..209c4e68b6 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1387,7 +1387,7 @@ This can run just once." (callee-in-unit (gethash callee (comp-ctxt-funcs-h comp-ctxt)))) (cond - ((and subrp (not (subr-native-elispp f))) + ((and subrp (not (subr-native-elisp-p f))) ;; Trampoline removal. (let* ((maxarg (cdr (subr-arity f))) (call-type (if (if subrp diff --git a/src/data.c b/src/data.c index 70068c30a7..2a32d47c49 100644 --- a/src/data.c +++ b/src/data.c @@ -865,7 +865,7 @@ SUBR must be a built-in function. */) } #ifdef HAVE_NATIVE_COMP -DEFUN ("subr-native-elispp", Fsubr_native_elispp, Ssubr_native_elispp, 1, 1, 0, +DEFUN ("subr-native-elisp-p", Fsubr_native_elisp_p, Ssubr_native_elisp_p, 1, 1, 0, doc: /* Return t if the subr is native compiled elisp, nil otherwise. */) (Lisp_Object subr) @@ -3995,7 +3995,7 @@ syms_of_data (void) defsubr (&Ssubr_arity); defsubr (&Ssubr_name); #ifdef HAVE_NATIVE_COMP - defsubr (&Ssubr_native_elispp); + defsubr (&Ssubr_native_elisp_p); #endif #ifdef HAVE_MODULES defsubr (&Suser_ptrp); commit 5630ebaf74f2f86e5d59fe4cba5ba96333e9fa6f Author: Andrea Corallo Date: Wed Sep 25 22:15:24 2019 +0200 do not force inlining for func involving ipa-pro diff --git a/src/comp.c b/src/comp.c index c968d2bf70..48ddba7eb2 100644 --- a/src/comp.c +++ b/src/comp.c @@ -2234,9 +2234,14 @@ define_CAR_CDR (void) NULL, comp.bool_type, "is_cons") }; + /* TODO: understand why after ipa-prop pass gcc is less keen on inlining + and as consequence can refuse to compile these. (see dhrystone.el) + Flag this and all the one involved in ipa-prop as + GCC_JIT_FUNCTION_INTERNAL not to fail compilation in case. + This seems at least to have no perf downside. */ func[i] = gcc_jit_context_new_function (comp.ctxt, NULL, - GCC_JIT_FUNCTION_ALWAYS_INLINE, + GCC_JIT_FUNCTION_INTERNAL, comp.lisp_obj_type, f_name [i], 2, param, 0); @@ -2321,7 +2326,7 @@ define_setcar_setcdr (void) gcc_jit_function **f_ref = !i ? &comp.setcar : &comp.setcdr; *f_ref = gcc_jit_context_new_function (comp.ctxt, NULL, - GCC_JIT_FUNCTION_ALWAYS_INLINE, + GCC_JIT_FUNCTION_INTERNAL, comp.lisp_obj_type, f_name[i], 3, param, 0); @@ -2389,7 +2394,7 @@ define_add1_sub1 (void) "is_fixnum") }; comp.func = func[i] = gcc_jit_context_new_function (comp.ctxt, NULL, - GCC_JIT_FUNCTION_ALWAYS_INLINE, + GCC_JIT_FUNCTION_INTERNAL, comp.lisp_obj_type, f_name[i], 2, @@ -2473,7 +2478,7 @@ define_negate (void) comp.func = comp.negate = gcc_jit_context_new_function (comp.ctxt, NULL, - GCC_JIT_FUNCTION_ALWAYS_INLINE, + GCC_JIT_FUNCTION_INTERNAL, comp.lisp_obj_type, "negate", 2, param, 0); commit 9c31066ccdd6dbc7e9bd7a9a56de5c3103841018 Author: Andrea Corallo Date: Tue Sep 24 22:08:28 2019 +0200 fix comp.el compilation diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 98d9e7376f..13bc3de5ac 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -379,7 +379,6 @@ Put PREFIX in front of it." "Byte compile FUNCTION-NAME spilling data from the byte compiler." (let* ((f (symbol-function function-name)) (func (make-comp-func :symbol-name function-name - :func f :c-func-name (comp-c-func-name function-name "F")))) commit bb25117eb40a08824142a5a56acc14d3fb4c89a4 Author: Andrea Corallo Date: Mon Sep 23 11:48:19 2019 +0200 add comp-native-compiling flag diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index c685a51666..98d9e7376f 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -45,6 +45,10 @@ (defconst native-compile-log-buffer "*Native-compile-Log*" "Name of the native-compiler's log buffer.") +(defvar comp-native-compiling nil + "This gets bound to t while native compilation. +Can be used by code that wants to expand differently in this case.") + ;; FIXME these has to be removed (defvar comp-speed 2) (defvar comp-verbose nil) @@ -1575,6 +1579,7 @@ If INPUT is a string, use it as the file path to be native compiled." (stringp input)) (error "Trying to native compile something not a symbol function or file")) (let ((data input) + (comp-native-compiling t) (comp-ctxt (make-comp-ctxt :output (if (symbolp input) (symbol-name input) (file-name-sans-extension input))))) commit 82a018e0622221910a7a02f683601c9f8c569cb1 Author: Andrea Corallo Date: Mon Sep 23 12:45:06 2019 +0200 better description diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 78455d5e7e..c685a51666 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -24,7 +24,7 @@ ;;; Commentary: ;; This code is an attempt to make the pig fly. -;; Or, to put it another way to make a Carrera out of a turbocharged VW Bug. +;; Or, to put it another way to make a 911 out of a turbocharged VW Bug. ;;; Code: @@ -1552,7 +1552,8 @@ Prepare every function for final compilation and drive the C back-end." ;;; Compiler type hints. ;; These are public entry points be used in user code to give comp suggestion ;; about types. -;; Note that types will propagates. +;; These can be used to implement CL style 'the', 'declare' or something like. +;; Note: types will propagates. ;; WARNING: At speed >= 2 type checking is not performed anymore and suggestions ;; are assumed just to be true. Use with extreme caution... commit d66d6ec5138049b98d99c4dcdd2c78582a6afe0f Author: Andrea Corallo Date: Mon Sep 23 11:41:36 2019 +0200 initial add for compiler hits diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 2525287716..78455d5e7e 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -70,9 +70,16 @@ (- . number) (* . number) (/ . number) - (% . number)) + (% . number) + ;; Type hint + (comp-hint-fixnum . fixnum) + (comp-hint-cons . cons)) "Alist used for type propagation.") +(defconst comp-type-hints '(comp-hint-fixnum + comp-hint-cons) + "List of fake functions used to give compiler hints.") + (defconst comp-limple-sets '(set setimm set-par-to-local @@ -257,6 +264,10 @@ structure.") (when (member (car-safe insn) comp-limple-calls) t)) +(defun comp-type-hint-p (func) + "Type hint predicate for function name FUNC." + (member func comp-type-hints)) + (defun comp-add-const-to-relocs (obj) "Keep track of OBJ into the ctxt relocations. The corresponding index is returned." @@ -1200,7 +1211,7 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non nil." (defun comp-ssa-rename-insn (insn frame) (dotimes (slot-n (comp-func-frame-size comp-func)) - (cl-flet ((target-p (x) + (cl-flet ((targetp (x) ;; Ret t if x is an mvar and target the correct slot number. (and (comp-mvar-p x) (eql slot-n (comp-mvar-slot x)))) @@ -1210,16 +1221,16 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non nil." (setf (aref frame slot-n) mvar) (setf (cadr insn) mvar)))) (pcase insn - (`(,(pred comp-assign-op-p) ,(pred target-p) . ,_) + (`(,(pred comp-assign-op-p) ,(pred targetp) . ,_) (let ((mvar (aref frame slot-n))) - (setcdr insn (cl-nsubst-if mvar #'target-p (cdr insn)))) + (setcdr insn (cl-nsubst-if mvar #'targetp (cdr insn)))) (new-lvalue)) (`(phi ,n) (when (equal n slot-n) (new-lvalue))) (_ (let ((mvar (aref frame slot-n))) - (setcdr insn (cl-nsubst-if mvar #'target-p (cdr insn))))))))) + (setcdr insn (cl-nsubst-if mvar #'targetp (cdr insn))))))))) (defun comp-ssa-rename () "Entry point to rename SSA within the current function." @@ -1397,7 +1408,9 @@ This can run just once." (args (if (eq call-type 'direct-callref) args (fill-args args (comp-args-max func-args))))) - `(,call-type ,callee ,@(clean-args-ref args))))))))) + `(,call-type ,callee ,@(clean-args-ref args)))) + ((comp-type-hint-p callee) + `(call ,callee ,@args))))))) (defun comp-call-optim-func () "Perform trampoline call optimization for the current function." @@ -1431,6 +1444,7 @@ This can run just once." ;; Even if gcc would take care of this is good to perform this here ;; in the hope of removing memory references (remember that most lisp ;; objects are loaded from the reloc array). +;; ;; This pass can be run as last optim. (defun comp-collect-mvar-ids (insn) @@ -1442,8 +1456,8 @@ This can run just once." when (comp-mvar-p x) collect (comp-mvar-id x))) -(defun comp-dead-code-func () - "Clean-up dead code into current function." +(defun comp-dead-assignments-func () + "Clean-up dead assignments into current function." (let ((l-vals ()) (r-vals ())) ;; Collect used r and l values. @@ -1476,15 +1490,28 @@ This can run just once." do (setcar insn-cell (if (comp-limple-insn-call-p rest) rest - `(comment ,(format "optimized out %s" + `(comment ,(format "optimized out: %s" insn))))))))) +(defun comp-remove-type-hints-func () + "Remove type hints from the current function. +These are substituted with normals 'set'." + (cl-loop + for b being each hash-value of (comp-func-blocks comp-func) + do (cl-loop + for insn-cell on (comp-block-insns b) + for insn = (car insn-cell) + do (pcase insn + (`(set ,l-val (call ,(pred comp-type-hint-p) ,r-val)) + (setcar insn-cell `(set ,l-val ,r-val))))))) + (defun comp-dead-code (_) "Dead code elimination." (when (>= comp-speed 2) (maphash (lambda (_ f) (let ((comp-func f)) - (comp-dead-code-func) + (comp-dead-assignments-func) + (comp-remove-type-hints-func) (comp-log-func comp-func))) (comp-ctxt-funcs-h comp-ctxt)))) @@ -1522,7 +1549,21 @@ Prepare every function for final compilation and drive the C back-end." compile-result)))) -;;; Entry points. +;;; Compiler type hints. +;; These are public entry points be used in user code to give comp suggestion +;; about types. +;; Note that types will propagates. +;; WARNING: At speed >= 2 type checking is not performed anymore and suggestions +;; are assumed just to be true. Use with extreme caution... + +(defun comp-hint-fixnum (x) + (cl-assert (fixnump x))) + +(defun comp-hint-cons (x) + (cl-assert (consp x))) + + +;;; Compiler entry points. (defun native-compile (input) "Compile INPUT into native code. commit d9db77704026ab0871325d431cae765981d167c2 Author: Andrea Corallo Date: Mon Sep 23 10:51:40 2019 +0200 rework comp-call-optim-form-call diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 913761b373..2525287716 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1372,31 +1372,32 @@ This can run just once." (subrp (subrp f)) (callee-in-unit (gethash callee (comp-ctxt-funcs-h comp-ctxt)))) - (if (and subrp (not (subr-native-elispp f))) - ;; Trampoline removal. - (let* ((maxarg (cdr (subr-arity f))) - (call-type (if (if subrp - (not (numberp maxarg)) - (comp-nargs-p callee-in-unit)) - 'callref - 'call)) - (args (if (eq call-type 'callref) - args - (fill-args args maxarg)))) - (comp-add-subr-to-relocs callee) - `(,call-type ,callee ,@(clean-args-ref args))) - ;; Intra compilation unit procedure call optimization. - (when (or (eq callee self) - ;; Attention speed 3 triggers that for non self calls too!! - (and (>= comp-speed 3) - callee-in-unit)) - (let* ((func-args (comp-func-args callee-in-unit)) - (nargs (comp-nargs-p func-args)) - (call-type (if nargs 'direct-callref 'direct-call)) - (args (if (eq call-type 'direct-callref) - args - (fill-args args (comp-args-max func-args))))) - `(,call-type ,callee ,@(clean-args-ref args))))))))) + (cond + ((and subrp (not (subr-native-elispp f))) + ;; Trampoline removal. + (let* ((maxarg (cdr (subr-arity f))) + (call-type (if (if subrp + (not (numberp maxarg)) + (comp-nargs-p callee-in-unit)) + 'callref + 'call)) + (args (if (eq call-type 'callref) + args + (fill-args args maxarg)))) + (comp-add-subr-to-relocs callee) + `(,call-type ,callee ,@(clean-args-ref args)))) + ;; Intra compilation unit procedure call optimization. + ;; Attention speed 3 triggers that for non self calls too!! + ((or (eq callee self) + (and (>= comp-speed 3) + callee-in-unit)) + (let* ((func-args (comp-func-args callee-in-unit)) + (nargs (comp-nargs-p func-args)) + (call-type (if nargs 'direct-callref 'direct-call)) + (args (if (eq call-type 'direct-callref) + args + (fill-args args (comp-args-max func-args))))) + `(,call-type ,callee ,@(clean-args-ref args))))))))) (defun comp-call-optim-func () "Perform trampoline call optimization for the current function." commit c0ac7d039fb003444769700d60d06538341ba884 Author: Andrea Corallo Date: Mon Sep 23 10:01:31 2019 +0200 add type hint to setcar setcdr diff --git a/src/comp.c b/src/comp.c index 1a22eccb43..c968d2bf70 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1473,6 +1473,23 @@ emit_call_with_type_hint (gcc_jit_function *func, Lisp_Object insn, return gcc_jit_context_new_call (comp.ctxt, NULL, func, 2, args); } +/* Same as before but with two args. The type hint is on the 2th. */ +static gcc_jit_rvalue * +emit_call2_with_type_hint (gcc_jit_function *func, Lisp_Object insn, + Lisp_Object type) +{ + bool type_hint = EQ (FUNCALL1 (comp-mvar-type, SECOND (insn)), type); + gcc_jit_rvalue *args[] = + { emit_mvar_val (SECOND (insn)), + emit_mvar_val (THIRD (insn)), + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.bool_type, + type_hint) }; + + return gcc_jit_context_new_call (comp.ctxt, NULL, func, 3, args); +} + + static gcc_jit_rvalue * emit_add1 (Lisp_Object insn) { @@ -1518,25 +1535,13 @@ emit_cdr (Lisp_Object insn) static gcc_jit_rvalue * emit_setcar (Lisp_Object insn) { - gcc_jit_rvalue *args[] = - { emit_mvar_val (SECOND (insn)), - emit_mvar_val (THIRD (insn)) }; - return gcc_jit_context_new_call (comp.ctxt, - NULL, - comp.setcar, - 2, args); + return emit_call2_with_type_hint (comp.setcar, insn, Qcons); } static gcc_jit_rvalue * emit_setcdr (Lisp_Object insn) { - gcc_jit_rvalue *args[] = - { emit_mvar_val (SECOND (insn)), - emit_mvar_val (THIRD (insn)) }; - return gcc_jit_context_new_call (comp.ctxt, - NULL, - comp.setcdr, - 2, args); + return emit_call2_with_type_hint (comp.setcdr, insn, Qcons); } static gcc_jit_rvalue * @@ -2217,7 +2222,7 @@ static void define_CAR_CDR (void) { gcc_jit_function *func[2]; - char const *f_name[] = {"CAR", "CDR"}; + char const *f_name[] = { "CAR", "CDR" }; for (int i = 0; i < 2; i++) { gcc_jit_param *param[] = @@ -2290,8 +2295,8 @@ define_CAR_CDR (void) static void define_setcar_setcdr (void) { - char const *f_name[] = {"setcar", "setcdr"}; - char const *par_name[] = {"new_car", "new_cdr"}; + char const *f_name[] = { "setcar", "setcdr" }; + char const *par_name[] = { "new_car", "new_cdr" }; for (int i = 0; i < 2; i++) { @@ -2306,16 +2311,20 @@ define_setcar_setcdr (void) comp.lisp_obj_type, par_name[i]); - gcc_jit_param *param[] = { cell, new_el }; + gcc_jit_param *param[] = + { cell, + new_el, + gcc_jit_context_new_param (comp.ctxt, + NULL, + comp.bool_type, + "is_cons") }; gcc_jit_function **f_ref = !i ? &comp.setcar : &comp.setcdr; *f_ref = gcc_jit_context_new_function (comp.ctxt, NULL, GCC_JIT_FUNCTION_ALWAYS_INLINE, comp.lisp_obj_type, f_name[i], - 2, - param, - 0); + 3, param, 0); DECL_BLOCK (entry_block, *f_ref); comp.func = *f_ref; comp.block = entry_block; @@ -2328,8 +2337,7 @@ define_setcar_setcdr (void) { gcc_jit_param_as_rvalue (cell), emit_XCONS (gcc_jit_param_as_rvalue (cell)) }; - gcc_jit_block_add_eval ( - entry_block, + gcc_jit_block_add_eval (entry_block, NULL, gcc_jit_context_new_call (comp.ctxt, NULL, @@ -2362,8 +2370,8 @@ define_add1_sub1 (void) { gcc_jit_block *bb_orig = comp.block; gcc_jit_function *func[2]; - char const *f_name[] = {"add1", "sub1"}; - char const *fall_back_func[] = {"1+", "1-"}; + char const *f_name[] = { "add1", "sub1" }; + char const *fall_back_func[] = { "1+", "1-" }; gcc_jit_rvalue *compare[] = { comp.most_positive_fixnum, comp.most_negative_fixnum }; enum gcc_jit_binary_op op[] = commit 8f3af3f61f43f2090bef30edbb9f8ae1a36c2e5d Author: Andrea Corallo Date: Mon Sep 23 09:37:58 2019 +0200 add type hint to car and cdr diff --git a/src/comp.c b/src/comp.c index 8ee667e10b..1a22eccb43 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1506,21 +1506,13 @@ emit_consp (Lisp_Object insn) static gcc_jit_rvalue * emit_car (Lisp_Object insn) { - gcc_jit_rvalue *x = emit_mvar_val (SECOND (insn)); - return gcc_jit_context_new_call (comp.ctxt, - NULL, - comp.car, - 1, &x); + return emit_call_with_type_hint (comp.car, insn, Qcons); } static gcc_jit_rvalue * emit_cdr (Lisp_Object insn) { - gcc_jit_rvalue *x = emit_mvar_val (SECOND (insn)); - return gcc_jit_context_new_call (comp.ctxt, - NULL, - comp.cdr, - 1, &x); + return emit_call_with_type_hint (comp.cdr, insn, Qcons); } static gcc_jit_rvalue * @@ -2224,63 +2216,52 @@ define_CHECK_TYPE (void) static void define_CAR_CDR (void) { - gcc_jit_param *car_param = - gcc_jit_context_new_param (comp.ctxt, - NULL, - comp.lisp_obj_type, - "c"); - comp.car = - gcc_jit_context_new_function (comp.ctxt, NULL, - GCC_JIT_FUNCTION_ALWAYS_INLINE, - comp.lisp_obj_type, - "CAR", - 1, - &car_param, - 0); - gcc_jit_param *cdr_param = - gcc_jit_context_new_param (comp.ctxt, - NULL, - comp.lisp_obj_type, - "c"); - comp.cdr = - gcc_jit_context_new_function (comp.ctxt, NULL, - GCC_JIT_FUNCTION_ALWAYS_INLINE, - comp.lisp_obj_type, - "CDR", - 1, - &cdr_param, - 0); - - gcc_jit_function *f = comp.car; - gcc_jit_param *param = car_param; - + gcc_jit_function *func[2]; + char const *f_name[] = {"CAR", "CDR"}; for (int i = 0; i < 2; i++) { - gcc_jit_rvalue *c = gcc_jit_param_as_rvalue (param); - DECL_BLOCK (entry_block, f); - DECL_BLOCK (is_cons_b, f); - DECL_BLOCK (not_a_cons_b, f); + gcc_jit_param *param[] = + { gcc_jit_context_new_param (comp.ctxt, + NULL, + comp.lisp_obj_type, + "c"), + gcc_jit_context_new_param (comp.ctxt, + NULL, + comp.bool_type, + "is_cons") }; + func[i] = + gcc_jit_context_new_function (comp.ctxt, NULL, + GCC_JIT_FUNCTION_ALWAYS_INLINE, + comp.lisp_obj_type, + f_name [i], + 2, param, 0); + gcc_jit_rvalue *c = gcc_jit_param_as_rvalue (param[0]); + DECL_BLOCK (entry_block, func[i]); + DECL_BLOCK (is_cons_b, func[i]); + DECL_BLOCK (not_a_cons_b, func[i]); comp.block = entry_block; - comp.func = f; - - emit_cond_jump (emit_CONSP (c), is_cons_b, not_a_cons_b); - - comp.block = is_cons_b; - - if (f == comp.car) - gcc_jit_block_end_with_return (comp.block, + comp.func = func[i]; + emit_cond_jump ( + gcc_jit_context_new_binary_op (comp.ctxt, NULL, - emit_XCAR (c)); + GCC_JIT_BINARY_OP_LOGICAL_OR, + comp.bool_type, + gcc_jit_param_as_rvalue (param[1]), + emit_cast (comp.bool_type, + emit_CONSP (c))), + is_cons_b, + not_a_cons_b); + comp.block = is_cons_b; + if (i == 0) + gcc_jit_block_end_with_return (comp.block, NULL, emit_XCAR (c)); else - gcc_jit_block_end_with_return (comp.block, - NULL, - emit_XCDR (c)); + gcc_jit_block_end_with_return (comp.block, NULL, emit_XCDR (c)); comp.block = not_a_cons_b; - DECL_BLOCK (is_nil_b, f); - DECL_BLOCK (not_nil_b, f); + DECL_BLOCK (is_nil_b, func[i]); + DECL_BLOCK (not_nil_b, func[i]); emit_cond_jump (emit_NILP (c), is_nil_b, not_nil_b); @@ -2301,9 +2282,9 @@ define_CAR_CDR (void) gcc_jit_block_end_with_return (comp.block, NULL, emit_const_lisp_obj (Qnil)); - f = comp.cdr; - param = cdr_param; } + comp.car = func[0]; + comp.cdr = func[1]; } static void commit bdea0f62b55e986136f5677369f354e4f5849863 Author: Andrea Corallo Date: Mon Sep 23 09:13:46 2019 +0200 add some call optimizer doc diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 34aafe401d..913761b373 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1341,7 +1341,19 @@ This can run just once." ;;; Call optimizer pass specific code. -;; Try to avoid funcall trampoline use when possible. +;; This pass is responsible for the following optimizations: +;; - Call to subrs that are in defined in the C source and are passing through +;; funcall trampoline gets optimized into normal indirect calls. +;; This makes effectively this calls equivalent to all the subrs that got +;; dedicated byte-code ops. +;; Triggered at comp-speed >= 2. +;; - Recursive calls gets optimized into direct calls. +;; Triggered at comp-speed >= 2. +;; - Intra compilation unit procedure calls gets optimized into direct calls. +;; This can be a big win and even allow gcc to inline but does not make +;; function in the compilation unit re-definable safely without recompiling +;; the full compilation unit. +;; For this reason this is triggered only at comp-speed == 3. (defun comp-call-optim-form-call (callee args self) "" @@ -1361,6 +1373,7 @@ This can run just once." (callee-in-unit (gethash callee (comp-ctxt-funcs-h comp-ctxt)))) (if (and subrp (not (subr-native-elispp f))) + ;; Trampoline removal. (let* ((maxarg (cdr (subr-arity f))) (call-type (if (if subrp (not (numberp maxarg)) commit 414a2b5bbc6ce441a8102254c593699e503d4f57 Author: Andrea Corallo Date: Sun Sep 22 21:54:38 2019 +0200 use type propagation into add1 sub1 negate diff --git a/src/comp.c b/src/comp.c index ce6a43af79..8ee667e10b 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1459,25 +1459,36 @@ emit_limple_insn (Lisp_Object insn) /* Inliners. */ /**************/ +static gcc_jit_rvalue * +emit_call_with_type_hint (gcc_jit_function *func, Lisp_Object insn, + Lisp_Object type) +{ + bool type_hint = EQ (FUNCALL1 (comp-mvar-type, SECOND (insn)), type); + gcc_jit_rvalue *args[] = + { emit_mvar_val (SECOND (insn)), + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.bool_type, + type_hint) }; + + return gcc_jit_context_new_call (comp.ctxt, NULL, func, 2, args); +} + static gcc_jit_rvalue * emit_add1 (Lisp_Object insn) { - gcc_jit_rvalue *n = emit_mvar_val (SECOND (insn)); - return gcc_jit_context_new_call (comp.ctxt, NULL, comp.add1, 1, &n); + return emit_call_with_type_hint (comp.add1, insn, Qfixnum); } static gcc_jit_rvalue * emit_sub1 (Lisp_Object insn) { - gcc_jit_rvalue *n = emit_mvar_val (SECOND (insn)); - return gcc_jit_context_new_call (comp.ctxt, NULL, comp.sub1, 1, &n); + return emit_call_with_type_hint (comp.sub1, insn, Qfixnum); } static gcc_jit_rvalue * emit_negate (Lisp_Object insn) { - gcc_jit_rvalue *n = emit_mvar_val (SECOND (insn)); - return gcc_jit_context_new_call (comp.ctxt, NULL, comp.negate, 1, &n); + return emit_call_with_type_hint (comp.negate, insn, Qfixnum); } static gcc_jit_rvalue * @@ -2369,7 +2380,6 @@ static void define_add1_sub1 (void) { gcc_jit_block *bb_orig = comp.block; - gcc_jit_function *func[2]; char const *f_name[] = {"add1", "sub1"}; char const *fall_back_func[] = {"1+", "1-"}; @@ -2377,32 +2387,46 @@ define_add1_sub1 (void) { comp.most_positive_fixnum, comp.most_negative_fixnum }; enum gcc_jit_binary_op op[] = { GCC_JIT_BINARY_OP_PLUS, GCC_JIT_BINARY_OP_MINUS }; - for (int i = 0; i < 2; i++) + for (unsigned i = 0; i < 2; i++) { - gcc_jit_param *param = gcc_jit_context_new_param (comp.ctxt, - NULL, - comp.lisp_obj_type, - "n"); + gcc_jit_param *param[] = + { gcc_jit_context_new_param (comp.ctxt, + NULL, + comp.lisp_obj_type, + "n"), + gcc_jit_context_new_param (comp.ctxt, + NULL, + comp.bool_type, + "is_fixnum") }; comp.func = func[i] = gcc_jit_context_new_function (comp.ctxt, NULL, GCC_JIT_FUNCTION_ALWAYS_INLINE, comp.lisp_obj_type, f_name[i], - 1, - ¶m, - 0); + 2, + param, 0); DECL_BLOCK (entry_block, func[i]); DECL_BLOCK (inline_block, func[i]); DECL_BLOCK (fcall_block, func[i]); comp.block = entry_block; - /* (FIXNUMP (n) && XFIXNUM (n) != MOST_POSITIVE_FIXNUM + /* is_fixnum || + ((FIXNUMP (n) && XFIXNUM (n) != MOST_POSITIVE_FIXNUM ? (XFIXNUM (n) + 1) : Fadd1 (n)) */ - gcc_jit_rvalue *n = gcc_jit_param_as_rvalue (param); + gcc_jit_rvalue *n = gcc_jit_param_as_rvalue (param[0]); gcc_jit_rvalue *n_fixnum = emit_XFIXNUM (n); + gcc_jit_rvalue *sure_fixnum = + gcc_jit_context_new_binary_op ( + comp.ctxt, + NULL, + GCC_JIT_BINARY_OP_LOGICAL_OR, + comp.bool_type, + gcc_jit_param_as_rvalue (param[1]), + emit_cast (comp.bool_type, + emit_FIXNUMP (n))); emit_cond_jump ( gcc_jit_context_new_binary_op ( @@ -2410,8 +2434,7 @@ define_add1_sub1 (void) NULL, GCC_JIT_BINARY_OP_LOGICAL_AND, comp.bool_type, - emit_cast (comp.bool_type, - emit_FIXNUMP (n)), + sure_fixnum, gcc_jit_context_new_comparison (comp.ctxt, NULL, GCC_JIT_COMPARISON_NE, @@ -2449,21 +2472,22 @@ static void define_negate (void) { gcc_jit_block *bb_orig = comp.block; - gcc_jit_param *param[] = - { gcc_jit_context_new_param (comp.ctxt, - NULL, - comp.lisp_obj_type, - "n") }; + { gcc_jit_context_new_param (comp.ctxt, + NULL, + comp.lisp_obj_type, + "n"), + gcc_jit_context_new_param (comp.ctxt, + NULL, + comp.bool_type, + "is_fixnum") }; comp.func = comp.negate = gcc_jit_context_new_function (comp.ctxt, NULL, GCC_JIT_FUNCTION_ALWAYS_INLINE, comp.lisp_obj_type, "negate", - 1, - param, - 0); + 2, param, 0); DECL_BLOCK (entry_block, comp.negate); DECL_BLOCK (inline_block, comp.negate); @@ -2471,13 +2495,20 @@ define_negate (void) comp.block = entry_block; - /* (FIXNUMP (TOP) && XFIXNUM (TOP) != MOST_NEGATIVE_FIXNUM - ? make_fixnum (- XFIXNUM (TOP)) - : Fminus (1, &TOP)) */ + /* (is_fixnum || FIXNUMP (TOP)) && XFIXNUM (TOP) != MOST_NEGATIVE_FIXNUM + ? make_fixnum (- XFIXNUM (TOP)) : Fminus (1, &TOP)) */ gcc_jit_lvalue *n = gcc_jit_param_as_lvalue (param[0]); - gcc_jit_rvalue *n_fixnum = - emit_XFIXNUM (gcc_jit_lvalue_as_rvalue (n)); + gcc_jit_rvalue *n_fixnum = emit_XFIXNUM (gcc_jit_lvalue_as_rvalue (n)); + gcc_jit_rvalue *sure_fixnum = + gcc_jit_context_new_binary_op ( + comp.ctxt, + NULL, + GCC_JIT_BINARY_OP_LOGICAL_OR, + comp.bool_type, + gcc_jit_param_as_rvalue (param[1]), + emit_cast (comp.bool_type, + emit_FIXNUMP (gcc_jit_lvalue_as_rvalue (n)))); emit_cond_jump ( gcc_jit_context_new_binary_op ( @@ -2485,8 +2516,7 @@ define_negate (void) NULL, GCC_JIT_BINARY_OP_LOGICAL_AND, comp.bool_type, - emit_cast (comp.bool_type, - emit_FIXNUMP (gcc_jit_lvalue_as_rvalue (n))), + sure_fixnum, gcc_jit_context_new_comparison (comp.ctxt, NULL, GCC_JIT_COMPARISON_NE, @@ -3305,6 +3335,8 @@ syms_of_comp (void) /* Returned values. */ DEFSYM (Qcomp_unit_open_failed, "comp-unit-open-failed"); DEFSYM (Qcomp_unit_init_failed, "comp-unit-init-failed"); + /* Others. */ + DEFSYM (Qfixnum, "fixnum"); defsubr (&Scomp__init_ctxt); defsubr (&Scomp__release_ctxt); commit 89abc8d66f7668060305e9f0e5dc3ebfddfff3fa Author: Andrea Corallo Date: Mon Sep 23 22:49:00 2019 +0200 move gcc_jit_context_dump_reproducer_to_file diff --git a/src/comp.c b/src/comp.c index 52309fe821..ce6a43af79 100644 --- a/src/comp.c +++ b/src/comp.c @@ -2863,8 +2863,6 @@ DEFUN ("comp--init-ctxt", Fcomp__init_ctxt, Scomp__init_ctxt, gcc_jit_context_set_bool_option (comp.ctxt, GCC_JIT_BOOL_OPTION_DUMP_EVERYTHING, 1); - gcc_jit_context_dump_reproducer_to_file (comp.ctxt, "comp_reproducer.c"); - } comp.void_type = gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_VOID); @@ -3038,6 +3036,8 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, (const char *) SDATA (CALLN (Fconcat, ctxtname, dot_c)); gcc_jit_context_dump_to_file (comp.ctxt, filename, 1); } + if (COMP_DEBUG > 1) + gcc_jit_context_dump_reproducer_to_file (comp.ctxt, "comp_reproducer.c"); AUTO_STRING (dot_so, NATIVE_ELISP_SUFFIX); const char *filename = commit 9b5f8ebb5bb970c34400b149190b2d16886ae814 Author: Andrea Corallo Date: Sun Sep 22 21:28:05 2019 +0200 fix missing direct call parsing in comp back-end diff --git a/src/comp.c b/src/comp.c index 4905dbfdca..52309fe821 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1316,6 +1316,17 @@ emit_limple_insn (Lisp_Object insn) gcc_jit_block_add_eval (comp.block, NULL, emit_limple_call_ref (args, false)); } + else if (EQ (op, Qdirect_call)) + { + gcc_jit_block_add_eval ( + comp.block, NULL, + emit_simple_limple_call (XCDR (insn), comp.lisp_obj_type, true)); + } + else if (EQ (op, Qdirect_callref)) + { + gcc_jit_block_add_eval (comp.block, NULL, + emit_limple_call_ref (XCDR (insn), true)); + } else if (EQ (op, Qset)) { Lisp_Object arg1 = SECOND (args); @@ -1328,7 +1339,7 @@ emit_limple_insn (Lisp_Object insn) res = emit_limple_call_ref (XCDR (arg1), false); else if (EQ (FIRST (arg1), Qdirect_call)) res = emit_simple_limple_call (XCDR (arg1), comp.lisp_obj_type, true); - else if (EQ (FIRST (arg1), Qcallref)) + else if (EQ (FIRST (arg1), Qdirect_callref)) res = emit_limple_call_ref (XCDR (arg1), true); else ice ("LIMPLE inconsistent arg1 for op ="); commit 59d53e1fde516b911c29cedf338779df29f59dff Author: Andrea Corallo Date: Sun Sep 22 20:58:26 2019 +0200 fix push handler propagation diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 24548242c3..34aafe401d 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -644,7 +644,9 @@ If NEGATED non nil negate the tested condition." (let ((guarded-bb (comp-new-block-sym))) (comp-block-maybe-add :name guarded-bb :sp (comp-sp)) (let ((handler-bb (comp-lap-to-limple-bb guarded-label))) - (comp-emit (list 'push-handler (comp-slot+1) + (comp-emit (list 'push-handler + (comp-slot+1) + (comp-slot+1) handler-type handler-bb guarded-bb)) @@ -1022,7 +1024,7 @@ Top level forms for the current context are rendered too." (cl-loop with blocks = (comp-func-blocks comp-func) for bb being each hash-value of blocks for last-insn = (car (last (comp-block-insns bb))) - for (op first second third forth) = last-insn + for (op first second third forth fifth) = last-insn do (cl-case op (jump (edge-add :src bb :dst (gethash first blocks))) @@ -1033,8 +1035,8 @@ Top level forms for the current context are rendered too." (edge-add :src bb :dst (gethash second blocks)) (edge-add :src bb :dst (gethash third blocks))) (push-handler - (edge-add :src bb :dst (gethash third blocks)) - (edge-add :src bb :dst (gethash forth blocks))) + (edge-add :src bb :dst (gethash forth blocks)) + (edge-add :src bb :dst (gethash fifth blocks))) (return) (otherwise (error "Block %s does not end with a branch in func %s" diff --git a/src/comp.c b/src/comp.c index afc7a3b187..4905dbfdca 100644 --- a/src/comp.c +++ b/src/comp.c @@ -62,6 +62,8 @@ along with GNU Emacs. If not, see . */ XCAR (XCDR (XCDR (x))) #define FORTH(x) \ XCAR (XCDR (XCDR (XCDR (x)))) +#define FIFTH(x) \ + XCAR (XCDR (XCDR (XCDR (XCDR (x))))) #define FUNCALL1(fun, arg) \ CALLN (Ffuncall, intern_c_string (STR(fun)), arg) @@ -1149,7 +1151,11 @@ emit_limple_push_handler (gcc_jit_rvalue *handler, gcc_jit_rvalue *handler_type, gcc_jit_block *handler_bb, gcc_jit_block *guarded_bb, Lisp_Object clobbered_mvar) { - /* Ex: (push-handler #s(comp-mvar 6 0 t (arith-error) nil) 1 bb_3 bb_2). */ + /* + Ex: (push-handler #s(comp-mvar 1 8 nil nil nil nil) + #s(comp-mvar 1 7 t done symbol nil) + catcher bb_2 bb_1). + */ static unsigned pushhandler_n; /* FIXME move at ctxt or func level. */ @@ -1158,8 +1164,7 @@ emit_limple_push_handler (gcc_jit_rvalue *handler, gcc_jit_rvalue *handler_type, gcc_jit_function_new_local (comp.func, NULL, comp.handler_ptr_type, - format_string ("c_%u", - pushhandler_n)); + format_string ("c_%u", pushhandler_n)); gcc_jit_rvalue *args[] = { handler, handler_type }; gcc_jit_block_add_assignment ( @@ -1263,9 +1268,10 @@ emit_limple_insn (Lisp_Object insn) { gcc_jit_rvalue *handler = emit_mvar_val (arg0); int h_num UNINIT; - if (EQ (SECOND (args), Qcatcher)) + Lisp_Object handler_spec = THIRD (args); + if (EQ (handler_spec, Qcatcher)) h_num = CATCHER; - else if (EQ (SECOND (args), Qcondition_case)) + else if (EQ (handler_spec, Qcondition_case)) h_num = CONDITION_CASE; else ice ("incoherent insn"); @@ -1273,8 +1279,8 @@ emit_limple_insn (Lisp_Object insn) gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.int_type, h_num); - gcc_jit_block *handler_bb = retrive_block (THIRD (args)); - gcc_jit_block *guarded_bb = retrive_block (FORTH (args)); + gcc_jit_block *handler_bb = retrive_block (FORTH (args)); + gcc_jit_block *guarded_bb = retrive_block (FIFTH (args)); emit_limple_push_handler (handler, handler_type, handler_bb, guarded_bb, arg0); } commit 84caa1a404cb89a6f02aa1cb517f5251e7e0e022 Author: Andrea Corallo Date: Sun Sep 22 19:13:32 2019 +0200 optimize nil emission diff --git a/src/comp.c b/src/comp.c index 6daeae311c..afc7a3b187 100644 --- a/src/comp.c +++ b/src/comp.c @@ -803,6 +803,12 @@ emit_const_lisp_obj (Lisp_Object obj) emit_comment (format_string ("const lisp obj: %s", SSDATA (Fprin1_to_string (obj, Qnil)))); + if (Qnil == NULL && EQ (obj, Qnil)) + return emit_cast (comp.lisp_obj_type, + gcc_jit_context_new_rvalue_from_ptr (comp.ctxt, + comp.void_ptr_type, + NULL)); + Lisp_Object d_reloc_idx = FUNCALL1 (comp-ctxt-data-relocs-idx, Vcomp_ctxt); ptrdiff_t reloc_fixn = XFIXNUM (Fgethash (obj, d_reloc_idx, Qnil)); gcc_jit_rvalue *reloc_n = commit 6eb77feeee2d85cca1d6695f809072c357875ba8 Author: Andrea Corallo Date: Sun Sep 22 19:04:11 2019 +0200 print object in comment when emitting with emit_const_lisp_obj diff --git a/src/comp.c b/src/comp.c index 60502da174..6daeae311c 100644 --- a/src/comp.c +++ b/src/comp.c @@ -800,7 +800,8 @@ emit_make_fixnum (gcc_jit_rvalue *obj) static gcc_jit_rvalue * emit_const_lisp_obj (Lisp_Object obj) { - emit_comment ("const lisp obj"); + emit_comment (format_string ("const lisp obj: %s", + SSDATA (Fprin1_to_string (obj, Qnil)))); Lisp_Object d_reloc_idx = FUNCALL1 (comp-ctxt-data-relocs-idx, Vcomp_ctxt); ptrdiff_t reloc_fixn = XFIXNUM (Fgethash (obj, d_reloc_idx, Qnil)); commit eaade31040503efdce5c0daccd4c06f856d3fe2f Author: Andrea Corallo Date: Sun Sep 22 19:00:28 2019 +0200 clean ref slot for mvars optimized by comp-call-optim-form-call diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index f65e779a17..24548242c3 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1346,7 +1346,13 @@ This can run just once." (cl-flet ((fill-args (args total) ;; Fill missing args to reach TOTAL (append args (cl-loop repeat (- total (length args)) - collect (make-comp-mvar :constant nil))))) + collect (make-comp-mvar :constant nil)))) + (clean-args-ref (args) + ;; Clean-up the ref slot in all args + (mapc (lambda (arg) + (setf (comp-mvar-ref arg) nil)) + args) + args)) (when (symbolp callee) ; Do nothing if callee is a byte compiled func. (let* ((f (symbol-function callee)) (subrp (subrp f)) @@ -1363,7 +1369,7 @@ This can run just once." args (fill-args args maxarg)))) (comp-add-subr-to-relocs callee) - `(,call-type ,callee ,@args)) + `(,call-type ,callee ,@(clean-args-ref args))) ;; Intra compilation unit procedure call optimization. (when (or (eq callee self) ;; Attention speed 3 triggers that for non self calls too!! @@ -1375,7 +1381,7 @@ This can run just once." (args (if (eq call-type 'direct-callref) args (fill-args args (comp-args-max func-args))))) - `(,call-type ,callee ,@args)))))))) + `(,call-type ,callee ,@(clean-args-ref args))))))))) (defun comp-call-optim-func () "Perform trampoline call optimization for the current function." commit d9670ef135893c41d33e5bd12c69659bb5d6158f Author: Andrea Corallo Date: Sun Sep 22 18:49:11 2019 +0200 add dead code removal pass diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index c3ec012c4a..f65e779a17 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -58,6 +58,7 @@ comp-propagate comp-call-optim comp-propagate + comp-dead-code comp-final) "Passes to be executed in order.") @@ -72,14 +73,23 @@ (% . number)) "Alist used for type propagation.") -(defconst comp-limple-assignments '(set - setimm - set-par-to-local - set-args-to-local - set-rest-args-to-local - push-handler) +(defconst comp-limple-sets '(set + setimm + set-par-to-local + set-args-to-local + set-rest-args-to-local) + "Limple set operators.") + +(defconst comp-limple-assignments `(push-handler + ,@comp-limple-sets) "Limple operators that clobbers the first mvar argument.") +(defconst comp-limple-calls '(call + callref + direct-call + direct-callref) + "Limple operators use to call subrs.") + (defconst comp-mostly-pure-funcs '(% * + - / /= 1+ 1- < <= = > >= cons list % concat logand logcount logior lognot logxor regexp-opt regexp-quote string-to-char string-to-syntax @@ -234,10 +244,19 @@ structure.") +(defun comp-set-op-p (op) + "Assignment predicate for OP." + (cl-find op comp-limple-sets)) + (defun comp-assign-op-p (op) "Assignment predicate for OP." (cl-find op comp-limple-assignments)) +(defun comp-limple-insn-call-p (insn) + "Limple INSN call predicate." + (when (member (car-safe insn) comp-limple-calls) + t)) + (defun comp-add-const-to-relocs (obj) "Keep track of OBJ into the ctxt relocations. The corresponding index is returned." @@ -1384,12 +1403,75 @@ This can run just once." (comp-call-optim-func))) (comp-ctxt-funcs-h comp-ctxt)))) + +;;; Dead code elimination pass specific code. +;; This simple pass try to eliminate insns became useful after propagation. +;; Even if gcc would take care of this is good to perform this here +;; in the hope of removing memory references (remember that most lisp +;; objects are loaded from the reloc array). +;; This pass can be run as last optim. + +(defun comp-collect-mvar-ids (insn) + "Collect the mvar unique identifiers into INSN." + (cl-loop for x in insn + if (consp x) + append (comp-collect-mvar-ids x) + else + when (comp-mvar-p x) + collect (comp-mvar-id x))) + +(defun comp-dead-code-func () + "Clean-up dead code into current function." + (let ((l-vals ()) + (r-vals ())) + ;; Collect used r and l values. + (cl-loop + for b being each hash-value of (comp-func-blocks comp-func) + do (cl-loop + for insn in (comp-block-insns b) + for (op arg0 . rest) = insn + if (comp-set-op-p op) + do (push (comp-mvar-id arg0) l-vals) + and + do (setf r-vals (nconc (comp-collect-mvar-ids rest) r-vals)) + else + do (setf r-vals (nconc (comp-collect-mvar-ids insn) r-vals)))) + ;; Every l-value appearing that does not appear as r-value has no right to + ;; exist and gets nuked. + (let ((nuke-list (cl-set-difference l-vals r-vals))) + (comp-log (format "Function %s\n" (comp-func-symbol-name comp-func))) + (comp-log (format "l-vals %s\n" l-vals)) + (comp-log (format "r-vals %s\n" r-vals)) + (comp-log (format "Nuking ids: %s\n" nuke-list)) + (cl-loop + for b being each hash-value of (comp-func-blocks comp-func) + do (cl-loop + for insn-cell on (comp-block-insns b) + for insn = (car insn-cell) + for (op arg0 rest) = insn + when (and (comp-set-op-p op) + (member (comp-mvar-id arg0) nuke-list)) + do (setcar insn-cell + (if (comp-limple-insn-call-p rest) + rest + `(comment ,(format "optimized out %s" + insn))))))))) + +(defun comp-dead-code (_) + "Dead code elimination." + (when (>= comp-speed 2) + (maphash (lambda (_ f) + (let ((comp-func f)) + (comp-dead-code-func) + (comp-log-func comp-func))) + (comp-ctxt-funcs-h comp-ctxt)))) + ;;; Final pass specific code. (defun comp-compile-ctxt-to-file (name) "Compile as native code the current context naming it NAME. -Prepare every functions for final compilation and drive the C side." +Prepare every function for final compilation and drive the C back-end." (cl-assert (= (length (comp-ctxt-data-relocs-l comp-ctxt)) (hash-table-count (comp-ctxt-data-relocs-idx comp-ctxt)))) (setf (comp-ctxt-exp-funcs comp-ctxt) diff --git a/src/comp.c b/src/comp.c index 042c536926..60502da174 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1295,10 +1295,14 @@ emit_limple_insn (Lisp_Object insn) } else if (EQ (op, Qcall)) { - gcc_jit_block_add_eval (comp.block, - NULL, + gcc_jit_block_add_eval (comp.block, NULL, emit_limple_call (args)); } + else if (EQ (op, Qcallref)) + { + gcc_jit_block_add_eval (comp.block, NULL, + emit_limple_call_ref (args, false)); + } else if (EQ (op, Qset)) { Lisp_Object arg1 = SECOND (args); @@ -2721,7 +2725,7 @@ compile_function (Lisp_Object func) - Enable gcc for better reordering (frame array is clobbered every time is passed as parameter being invoved into an nargs function call). - Allow gcc to trigger other optimizations that are prevented by memory - referencing (ex TCO). + referencing. */ if (comp_speed >= 2) { commit e3ed0208a8ce25ed1d6c82e7e5bb3058d074afc5 Author: Andrea Corallo Date: Sun Sep 22 17:58:35 2019 +0200 better note diff --git a/src/comp.c b/src/comp.c index 00fda6e705..042c536926 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1534,9 +1534,9 @@ emit_static_object (const char *name, Lisp_Object obj) /* libgccjit has no support for initialized static data. The mechanism below is certainly not aesthetic but I assume the bottle neck in terms of performance at load time will still be the reader. - NOTE: we can not relay on it even for valid C strings cause of - this funny bug that will affect all pre gcc10 era gccs: - https://gcc.gnu.org/ml/jit/2019-q3/msg00013.html */ + NOTE: we can not relay on libgccjit even for valid NULL terminated C + strings cause of this funny bug that will affect all pre gcc10 era gccs: + https://gcc.gnu.org/ml/jit/2019-q3/msg00013.html */ Lisp_Object str = Fprin1_to_string (obj, Qnil); ptrdiff_t len = SBYTES (str); commit 86a22004c9bdd1e93aac773cfda1932061f3b724 Author: Andrea Corallo Date: Sun Sep 22 17:11:53 2019 +0200 repropagate after call-optim diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index b66bccede5..c3ec012c4a 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -57,6 +57,7 @@ comp-ssa comp-propagate comp-call-optim + comp-propagate comp-final) "Passes to be executed in order.") @@ -1278,10 +1279,10 @@ This can run just once." (pcase insn (`(set ,lval ,rval) (pcase rval - (`(call ,f . ,_) + (`(,(or 'call 'direct-call) ,f . ,_) (setf (comp-mvar-type lval) (cdr (assq f comp-known-ret-types)))) - (`(callref ,f . ,args) + (`(,(or 'callref 'direct-callref) ,f . ,args) (cl-loop for v in args do (setf (comp-mvar-ref v) t)) (setf (comp-mvar-type lval) commit 6e205873992a2f8eeaecb30adf56346481a2c192 Author: Andrea Corallo Date: Sun Sep 22 16:37:57 2019 +0200 floating frame in place diff --git a/src/comp.c b/src/comp.c index 2abf4d2a2b..00fda6e705 100644 --- a/src/comp.c +++ b/src/comp.c @@ -149,6 +149,7 @@ typedef struct { gcc_jit_function *func; /* Current function being compiled. */ gcc_jit_block *block; /* Current basic block being compiled. */ gcc_jit_lvalue **frame; /* Frame for the current function. */ + gcc_jit_lvalue **f_frame; /* "Floating" frame for the current function. */ gcc_jit_rvalue *most_positive_fixnum; gcc_jit_rvalue *most_negative_fixnum; gcc_jit_rvalue *one; @@ -282,6 +283,16 @@ declare_block (Lisp_Object block_name) Fputhash (block_name, value, comp.func_blocks_h); } +static gcc_jit_lvalue * +get_slot (Lisp_Object mvar) +{ + EMACS_INT slot_n = XFIXNUM (FUNCALL1 (comp-mvar-slot, mvar)); + gcc_jit_lvalue **frame = + (FUNCALL1 (comp-mvar-ref, mvar) || comp_speed < 2) + ? comp.frame : comp.f_frame; + return frame[slot_n]; +} + static void register_emitter (Lisp_Object key, void *func) { @@ -1024,8 +1035,18 @@ emit_mvar_val (Lisp_Object mvar) return emit_const_lisp_obj (constant); } - return - gcc_jit_lvalue_as_rvalue(comp.frame[XFIXNUM (FUNCALL1 (comp-mvar-slot, mvar))]); + return gcc_jit_lvalue_as_rvalue (get_slot (mvar)); +} + +static void +emit_frame_assignment (Lisp_Object dst_mvar, gcc_jit_rvalue *val) +{ + + gcc_jit_block_add_assignment ( + comp.block, + NULL, + get_slot (dst_mvar), + val); } static gcc_jit_rvalue * @@ -1119,7 +1140,7 @@ emit_limple_call_ref (Lisp_Object insn, bool direct) static void emit_limple_push_handler (gcc_jit_rvalue *handler, gcc_jit_rvalue *handler_type, gcc_jit_block *handler_bb, gcc_jit_block *guarded_bb, - EMACS_UINT clobber_slot) + Lisp_Object clobbered_mvar) { /* Ex: (push-handler #s(comp-mvar 6 0 t (arith-error) nil) 1 bb_3 bb_2). */ @@ -1169,10 +1190,8 @@ emit_limple_push_handler (gcc_jit_rvalue *handler, gcc_jit_rvalue *handler_type, gcc_jit_rvalue_dereference_field (gcc_jit_lvalue_as_rvalue (c), NULL, comp.handler_next_field))); - gcc_jit_block_add_assignment ( - comp.block, - NULL, - comp.frame[clobber_slot], + emit_frame_assignment ( + clobbered_mvar, gcc_jit_lvalue_as_rvalue( gcc_jit_rvalue_dereference_field (gcc_jit_lvalue_as_rvalue (c), NULL, @@ -1235,7 +1254,6 @@ emit_limple_insn (Lisp_Object insn) } else if (EQ (op, Qpush_handler)) { - EMACS_UINT clobber_slot = XFIXNUM (FUNCALL1 (comp-mvar-slot, arg0)); gcc_jit_rvalue *handler = emit_mvar_val (arg0); int h_num UNINIT; if (EQ (SECOND (args), Qcatcher)) @@ -1251,7 +1269,7 @@ emit_limple_insn (Lisp_Object insn) gcc_jit_block *handler_bb = retrive_block (THIRD (args)); gcc_jit_block *guarded_bb = retrive_block (FORTH (args)); emit_limple_push_handler (handler, handler_type, handler_bb, guarded_bb, - clobber_slot); + arg0); } else if (EQ (op, Qpop_handler)) { @@ -1283,7 +1301,6 @@ emit_limple_insn (Lisp_Object insn) } else if (EQ (op, Qset)) { - EMACS_UINT slot_n = XFIXNUM (FUNCALL1 (comp-mvar-slot, arg0)); Lisp_Object arg1 = SECOND (args); if (EQ (Ftype_of (arg1), Qcomp_mvar)) @@ -1301,23 +1318,16 @@ emit_limple_insn (Lisp_Object insn) ICE_IF (!res, gcc_jit_context_get_first_error (comp.ctxt)); - gcc_jit_block_add_assignment (comp.block, - NULL, - comp.frame[slot_n], - res); + emit_frame_assignment (arg0, res); } else if (EQ (op, Qset_par_to_local)) { /* Ex: (setpar #s(comp-mvar 2 0 nil nil nil) 0). */ - EMACS_UINT slot_n = XFIXNUM (FUNCALL1 (comp-mvar-slot, arg0)); EMACS_UINT param_n = XFIXNUM (SECOND (args)); gcc_jit_rvalue *param = gcc_jit_param_as_rvalue (gcc_jit_function_get_param (comp.func, param_n)); - gcc_jit_block_add_assignment (comp.block, - NULL, - comp.frame[slot_n], - param); + emit_frame_assignment (arg0, param); } else if (EQ (op, Qset_args_to_local)) { @@ -1332,11 +1342,7 @@ emit_limple_insn (Lisp_Object insn) gcc_jit_rvalue *res = gcc_jit_lvalue_as_rvalue (gcc_jit_rvalue_dereference (gcc_args, NULL)); - EMACS_UINT slot_n = XFIXNUM (FUNCALL1 (comp-mvar-slot, arg0)); - gcc_jit_block_add_assignment (comp.block, - NULL, - comp.frame[slot_n], - res); + emit_frame_assignment (arg0, res); } else if (EQ (op, Qset_rest_args_to_local)) { @@ -1367,10 +1373,7 @@ emit_limple_insn (Lisp_Object insn) res = emit_call (Qlist, comp.lisp_obj_type, 2, list_args, false); - gcc_jit_block_add_assignment (comp.block, - NULL, - comp.frame[slot_n], - res); + emit_frame_assignment (arg0, res); } else if (EQ (op, Qinc_args)) { @@ -1393,21 +1396,18 @@ emit_limple_insn (Lisp_Object insn) else if (EQ (op, Qsetimm)) { /* EX: (=imm #s(comp-mvar 9 1 t 3 nil) 3 a). */ - EMACS_UINT slot_n = XFIXNUM (FUNCALL1 (comp-mvar-slot, arg0)); gcc_jit_rvalue *reloc_n = gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.int_type, XFIXNUM (SECOND (args))); emit_comment (SSDATA (Fprin1_to_string (THIRD (args), Qnil))); - gcc_jit_block_add_assignment (comp.block, - NULL, - comp.frame[slot_n], - gcc_jit_lvalue_as_rvalue ( - gcc_jit_context_new_array_access ( - comp.ctxt, - NULL, - comp.data_relocs, - reloc_n))); + emit_frame_assignment ( + arg0, + gcc_jit_lvalue_as_rvalue ( + gcc_jit_context_new_array_access (comp.ctxt, + NULL, + comp.data_relocs, + reloc_n))); } else if (EQ (op, Qcomment)) { @@ -2703,9 +2703,8 @@ compile_function (Lisp_Object func) comp.lisp_obj_type, frame_size), "local"); - comp.frame = SAFE_ALLOCA (frame_size * sizeof (*comp.frame)); - for (int i = 0; i < frame_size; ++i) + for (unsigned i = 0; i < frame_size; ++i) comp.frame[i] = gcc_jit_context_new_array_access ( comp.ctxt, @@ -2715,6 +2714,26 @@ compile_function (Lisp_Object func) comp.int_type, i)); + /* + The floating frame is a copy of the normal frame that can be used to store + locals if the are not going to be used in a nargs call. + This has two advantages: + - Enable gcc for better reordering (frame array is clobbered every time is + passed as parameter being invoved into an nargs function call). + - Allow gcc to trigger other optimizations that are prevented by memory + referencing (ex TCO). + */ + if (comp_speed >= 2) + { + comp.f_frame = SAFE_ALLOCA (frame_size * sizeof (*comp.f_frame)); + for (unsigned i = 0; i < frame_size; ++i) + comp.f_frame[i] = + gcc_jit_function_new_local (comp.func, + NULL, + comp.lisp_obj_type, + format_string ("local%u", i)); + } + comp.func_blocks_h = CALLN (Fmake_hash_table); /* Pre declare all basic blocks to gcc. commit 772357698a226cdbf123d04d58573b79fd8814a2 Author: Andrea Corallo Date: Sun Sep 22 16:11:48 2019 +0200 fix nomenclature into declare_function diff --git a/src/comp.c b/src/comp.c index b25013d65a..2abf4d2a2b 100644 --- a/src/comp.c +++ b/src/comp.c @@ -2635,10 +2635,10 @@ declare_function (Lisp_Object func) gcc_jit_function *gcc_func; char *c_name = SSDATA (FUNCALL1 (comp-func-c-func-name, func)); Lisp_Object args = FUNCALL1 (comp-func-args, func); - bool ncall = (FUNCALL1 (comp-nargs-p, args)); + bool nargs = (FUNCALL1 (comp-nargs-p, args)); USE_SAFE_ALLOCA; - if (!ncall) + if (!nargs) { EMACS_INT max_args = XFIXNUM (FUNCALL1 (comp-args-max, args)); gcc_jit_type **type = SAFE_ALLOCA (max_args * sizeof (*type)); commit c8d745d10a45ca3f378d7434f1cff73ae02ba42d Author: Andrea Corallo Date: Sun Sep 22 15:42:49 2019 +0200 clean-up pass mechanism diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 7d0c0671e8..b66bccede5 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -968,12 +968,12 @@ This will be called at runtime." func (comp-ctxt-funcs-h comp-ctxt))) -(defun comp-limplify (funcs) - "Compute the LIMPLE ir for FUNCS. +(defun comp-limplify (lap-funcs) + "Compute the LIMPLE ir for LAP-FUNCS. Top level forms for the current context are rendered too." (mapc #'comp-add-func-to-ctxt (cons (comp-limplify-top-level) - (mapcar #'comp-limplify-function funcs)))) + (mapcar #'comp-limplify-function lap-funcs)))) ;;; SSA pass specific code. @@ -1236,22 +1236,22 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non nil." when (eq op 'phi) do (finalize-phi args b))))) -(defun comp-ssa (funcs) +(defun comp-ssa (_) "Port FUNCS into mininal SSA form." - (cl-loop for comp-func in funcs - do (progn - ;; TODO: if this is run more than once we should clean all CFG - ;; data including phis here. - (comp-func-reset-generators comp-func) - (comp-compute-edges) - (comp-compute-dominator-tree) - (comp-compute-dominator-frontiers) - (comp-log-block-info) - (comp-place-phis) - (comp-ssa-rename) - (comp-finalize-phis) - (comp-log-func comp-func))) - funcs) + (maphash (lambda (_ f) + (let ((comp-func f)) + ;; TODO: if this is run more than once we should clean all CFG + ;; data including phis here. + (comp-func-reset-generators comp-func) + (comp-compute-edges) + (comp-compute-dominator-tree) + (comp-compute-dominator-frontiers) + (comp-log-block-info) + (comp-place-phis) + (comp-ssa-rename) + (comp-finalize-phis) + (comp-log-func comp-func))) + (comp-ctxt-funcs-h comp-ctxt))) ;;; propagate pass specific code. @@ -1307,16 +1307,15 @@ This can run just once." do (cl-loop for insn in (comp-block-insns b) do (comp-propagate-insn insn)))) -(defun comp-propagate (funcs) - (cl-loop for comp-func in funcs - do - (progn - (comp-basic-const-propagate) - ;; FIXME: unbelievably dumb... - (cl-loop repeat 10 - do (comp-propagate*)) - (comp-log-func comp-func))) - funcs) +(defun comp-propagate (_) + (maphash (lambda (_ f) + (let ((comp-func f)) + (comp-basic-const-propagate) + ;; FIXME: unbelievably dumb... + (cl-loop repeat 10 + do (comp-propagate*)) + (comp-log-func comp-func))) + (comp-ctxt-funcs-h comp-ctxt))) ;;; Call optimizer pass specific code. @@ -1358,28 +1357,31 @@ This can run just once." (fill-args args (comp-args-max func-args))))) `(,call-type ,callee ,@args)))))))) -(defun comp-call-optim (funcs) - "Given FUNCS try to avoid funcall trampoline usage when possible." +(defun comp-call-optim-func () + "Perform trampoline call optimization for the current function." (cl-loop - for comp-func in funcs - for self = (comp-func-symbol-name comp-func) - when (>= comp-speed 2) + with self = (comp-func-symbol-name comp-func) + for b being each hash-value of (comp-func-blocks comp-func) do (cl-loop - for b being each hash-value of (comp-func-blocks comp-func) - do (cl-loop - for insn-cell on (comp-block-insns b) - for insn = (car insn-cell) - do (pcase insn - (`(set ,lval (callref funcall ,f . ,rest)) - (when-let ((new-form (comp-call-optim-form-call - (comp-mvar-constant f) rest self))) - (setcar insn-cell `(set ,lval ,new-form)))) - (`(callref funcall ,f . ,rest) - (when-let ((new-form (comp-call-optim-form-call - (comp-mvar-constant f) rest self))) - (setcar insn-cell ,new-form)))))) - (comp-log-func comp-func)) - funcs) + for insn-cell on (comp-block-insns b) + for insn = (car insn-cell) + do (pcase insn + (`(set ,lval (callref funcall ,f . ,rest)) + (when-let ((new-form (comp-call-optim-form-call + (comp-mvar-constant f) rest self))) + (setcar insn-cell `(set ,lval ,new-form)))) + (`(callref funcall ,f . ,rest) + (when-let ((new-form (comp-call-optim-form-call + (comp-mvar-constant f) rest self))) + (setcar insn-cell ,new-form))))))) + +(defun comp-call-optim (_) + "Given FUNCS try to avoid funcall trampoline usage when possible." + (when (>= comp-speed 2) + (maphash (lambda (_ f) + (let ((comp-func f)) + (comp-call-optim-func))) + (comp-ctxt-funcs-h comp-ctxt)))) ;;; Final pass specific code. commit b45122b7132bb4b7e41fff5434e669e4ca671b8c Author: Andrea Corallo Date: Sun Sep 22 15:02:00 2019 +0200 rework basic block entry sp emission diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 527d855af6..7d0c0671e8 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -442,9 +442,14 @@ Restore the original value afterwards." (block-name nil :type symbol :documentation "Current basic block name.")) -(cl-defun comp-block-maybe-add (&rest args &key name &allow-other-keys) +(cl-defun comp-block-maybe-add (&rest args &key name sp &allow-other-keys) (let ((blocks (comp-func-blocks comp-func))) - (unless (gethash name blocks) + (if-let ((bb (gethash name blocks))) + (if-let ((bb-sp (comp-block-sp bb))) + ;; If was a sp was already registered sanity check it. + (cl-assert (or (null sp) (= sp bb-sp))) + ;; Otherwise set it. + (setf (comp-block-sp bb) sp)) (puthash name (apply #'make--comp-block args) blocks)))) ;; (defun comp-opt-call (inst) @@ -547,12 +552,13 @@ If DST-N is specified use it otherwise assume it to be the current slot." (comp-emit (list 'jump target)) (comp-mark-block-closed)) -(defun comp-emit-block (block-name) - "Emit basic block BLOCK-NAME." +(defun comp-emit-block (block-name &optional entry-sp) + "Emit basic block BLOCK-NAME. +ENTRY-SP is the sp value when entering." (let ((blocks (comp-func-blocks comp-func))) ;; In case does not exist register it into comp-func-blocks. (comp-block-maybe-add :name block-name - :sp (comp-sp)) + :sp entry-sp) ;; If we are abandoning an non closed basic block close it with a fall ;; through. (when (and (not (eq block-name 'entry)) @@ -562,9 +568,10 @@ If DST-N is specified use it otherwise assume it to be the current slot." (comp-emit-jump block-name)) ;; Set this a currently compiled block. (setf comp-block (gethash block-name blocks)) - ;; If we are landing here form a recorded branch adjust sp accordingly. - (setf (comp-sp) - (comp-block-sp (gethash block-name blocks))) + ;; If we are landing here from a previously recorded branch with known sp + ;; adjust accordingly. + (when-let ((new-sp (comp-block-sp (gethash block-name blocks)))) + (setf (comp-sp) new-sp)) (setf (comp-limplify-block-name comp-pass) block-name))) (defun comp-emit-cond-jump (a b target-offset lap-label negated) @@ -580,7 +587,7 @@ If NEGATED non nil negate the tested condition." (list 'cond-jump a b bb target))) (comp-block-maybe-add :name target :sp (+ target-offset (comp-sp))) (comp-mark-block-closed)) - (comp-emit-block bb))) + (comp-emit-block bb (comp-sp)))) (defun comp-stack-adjust (n) "Move sp by N." @@ -623,7 +630,7 @@ If NEGATED non nil negate the tested condition." guarded-bb)) (comp-block-maybe-add :name handler-bb :sp (1+ (comp-sp))) (comp-mark-block-closed) - (comp-emit-block guarded-bb)))) + (comp-emit-block guarded-bb (comp-sp))))) (defun comp-emit-switch (var last-insn) "Emit a limple for a lap jump table given VAR and LAST-INSN." @@ -890,15 +897,16 @@ the annotation emission." do (progn (comp-emit `(cond-jump-narg-leq ,i ,bb ,fallback)) (comp-mark-block-closed) - (comp-emit-block bb) + (comp-emit-block bb (comp-sp)) (comp-emit `(set-args-to-local ,(comp-slot-n i))) (comp-emit '(inc-args))) finally (comp-emit-jump 'entry_rest_args)) (cl-loop for i from minarg below nonrest do (comp-with-sp i - (comp-emit-block (intern (format "entry_fallback_%s" i))) + (comp-emit-block (intern (format "entry_fallback_%s" i)) + (comp-sp)) (comp-emit-set-const nil))) - (comp-emit-block 'entry_rest_args) + (comp-emit-block 'entry_rest_args (comp-sp)) (comp-emit `(set-rest-args-to-local ,(comp-slot-n nonrest)))) (defun comp-limplify-finalize-function (func) @@ -921,7 +929,7 @@ This will be called at runtime." :sp -1 :frame (comp-new-frame 0))) (comp-block ())) - (comp-emit-block 'entry) + (comp-emit-block 'entry (comp-sp)) (comp-emit-annotation "Top level") (cl-loop for args in (comp-ctxt-top-level-defvars comp-ctxt) do (comp-emit (comp-call 'defvar (make-comp-mvar :constant args)))) @@ -939,7 +947,7 @@ This will be called at runtime." (args-min (comp-args-base-min args)) (comp-block ())) ;; Prologue - (comp-emit-block 'entry) + (comp-emit-block 'entry (comp-sp)) (comp-emit-annotation (concat "Lisp function: " (symbol-name (comp-func-symbol-name func)))) (if (comp-args-p args) @@ -950,7 +958,7 @@ This will be called at runtime." (comp-emit-narg-prologue args-min nonrest) (cl-incf (comp-sp) (1+ nonrest)))) ;; Body - (comp-emit-block (comp-new-block-sym)) + (comp-emit-block (comp-new-block-sym) (comp-sp)) (mapc #'comp-limplify-lap-inst (comp-func-lap func)) (comp-limplify-finalize-function func))) commit fcab7f72e1765b883537a0ae2c3a82a802539375 Author: Andrea Corallo Date: Sun Sep 22 09:59:14 2019 +0200 fix comp-new-block-sym diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index b5d54289de..527d855af6 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -599,11 +599,11 @@ If NEGATED non nil negate the tested condition." (comp-slot+1)))))) (defun comp-new-block-sym () - "Return a symbol naming the next new basic block." - (intern (format "bb_%s" (hash-table-count (comp-func-blocks comp-func))))) + "Return a unique symbol naming the next new basic block." + (intern (format "bb_%s" (funcall (comp-func-block-cnt-gen comp-func))))) (defun comp-lap-to-limple-bb (n) - "Given the LAP label N return the limple basic block." + "Given the LAP label N return the limple basic block name." (let ((hash (comp-func-lap-block comp-func))) (if-let ((bb (gethash n hash))) ;; If was already created return it. @@ -950,7 +950,7 @@ This will be called at runtime." (comp-emit-narg-prologue args-min nonrest) (cl-incf (comp-sp) (1+ nonrest)))) ;; Body - (comp-emit-block 'bb_1) + (comp-emit-block (comp-new-block-sym)) (mapc #'comp-limplify-lap-inst (comp-func-lap func)) (comp-limplify-finalize-function func))) commit a49be9dba96575b68f0657c21eebcfbb56463021 Author: Andrea Corallo Date: Sun Sep 22 09:58:20 2019 +0200 better comp-func doc diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index dd3b5200bc..b5d54289de 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -186,23 +186,26 @@ Is in use to help the SSA rename pass.")) (byte-func nil :documentation "Byte compiled version.") (lap () :type list - :documentation "Lap assembly representation.") + :documentation "LAP assembly representation.") (args nil :type comp-args-base) (frame-size nil :type number) (blocks (make-hash-table) :type hash-table :documentation "Key is the basic block symbol value is a comp-block structure.") (lap-block (make-hash-table :test #'equal) :type hash-table - :documentation "LAP lable -> LIMPLE basic block.") + :documentation "LAP lable -> LIMPLE basic block name.") (edges () :type list :documentation "List of edges connecting basic blocks.") + (block-cnt-gen (funcall #'comp-gen-counter) :type function + :documentation "Generates block numbers.") (edge-cnt-gen (funcall #'comp-gen-counter) :type function - :documentation "Generates edges numbers.") + :documentation "Generates edges numbers.") (ssa-cnt-gen (funcall #'comp-gen-counter) :type function :documentation "Counter to create ssa limple vars.")) (defun comp-func-reset-generators (func) "Reset unique id generators for FUNC." + ;; (setf (block-cnt-gen func) (comp-gen-counter)) (setf (comp-func-edge-cnt-gen func) (comp-gen-counter)) (setf (comp-func-ssa-cnt-gen func) (comp-gen-counter))) commit 4c33696014d28975bce559a333c845fffc695428 Author: Andrea Corallo Date: Sun Sep 22 09:57:15 2019 +0200 remove unused field into comp-func diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 8761312a54..dd3b5200bc 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -183,8 +183,6 @@ Is in use to help the SSA rename pass.")) :documentation "Function symbol's name.") (c-func-name nil :type string :documentation "The function name in the native world.") - (func nil - :documentation "Original form.") (byte-func nil :documentation "Byte compiled version.") (lap () :type list commit 4a0adfec2a1caabca3bf99881f98f24ad12216f9 Author: Andrea Corallo Date: Sat Sep 21 19:14:20 2019 +0200 better doc for comp-func struct diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 01edd2b18f..8761312a54 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -195,8 +195,7 @@ Is in use to help the SSA rename pass.")) :documentation "Key is the basic block symbol value is a comp-block structure.") (lap-block (make-hash-table :test #'equal) :type hash-table - :documentation "Key value to convert from LAP label number to -LIMPLE basic block.") + :documentation "LAP lable -> LIMPLE basic block.") (edges () :type list :documentation "List of edges connecting basic blocks.") (edge-cnt-gen (funcall #'comp-gen-counter) :type function commit be1b64bdb515d8328228138982850475d15a0feb Author: Andrea Corallo Date: Sat Sep 21 19:13:11 2019 +0200 strengthening comp-compute-edges diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 83e8f8485b..01edd2b18f 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -995,7 +995,7 @@ Top level forms for the current context are rendered too." for bb being each hash-value of blocks for last-insn = (car (last (comp-block-insns bb))) for (op first second third forth) = last-insn - do (cl-ecase op + do (cl-case op (jump (edge-add :src bb :dst (gethash first blocks))) (cond-jump @@ -1007,7 +1007,10 @@ Top level forms for the current context are rendered too." (push-handler (edge-add :src bb :dst (gethash third blocks)) (edge-add :src bb :dst (gethash forth blocks))) - (return)) + (return) + (otherwise + (error "Block %s does not end with a branch in func %s" + bb (comp-func-symbol-name comp-func)))) finally (progn (setf (comp-func-edges comp-func) (nreverse (comp-func-edges comp-func))) commit c6be6fd6ccca9b9af1d9c5916d3da39f965e0ec5 Author: Andrea Corallo Date: Sat Sep 21 18:13:13 2019 +0200 verify to never emit insns into a closed block diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 9f0068681b..83e8f8485b 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -484,6 +484,7 @@ Restore the original value afterwards." (defun comp-emit (insn) "Emit INSN into current basic block." + (cl-assert (not (comp-block-closed comp-block))) (push insn (comp-block-insns comp-block))) (defun comp-emit-set-call (call) commit 5976919a3325c4512e450b9649a510f05e7d4fcd Author: Andrea Corallo Date: Sat Sep 21 17:19:20 2019 +0200 better logging diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index e1e0858985..9f0068681b 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -281,7 +281,8 @@ BODY is evaluate only if `comp-debug' is non nil." (insert data) (mapc (lambda (x) (insert (prin1-to-string x) "\n")) - data))))) + data) + (insert "\n"))))) (defun comp-log-func (func) "Log function FUNC." @@ -289,7 +290,7 @@ BODY is evaluate only if `comp-debug' is non nil." (cl-loop for block-name being each hash-keys of (comp-func-blocks func) using (hash-value bb) do (progn - (comp-log (concat "\n<" (symbol-name block-name) ">\n")) + (comp-log (concat "<" (symbol-name block-name) ">\n")) (comp-log (comp-block-insns bb))))) (defun comp-log-edges (func) @@ -384,7 +385,9 @@ Put PREFIX in front of it." :args (comp-decrypt-lambda-list lambda-list) :lap lap :frame-size (aref bytecode 3)) - do (comp-log lap) + do (progn + (comp-log (format "Function %s:\n" name)) + (comp-log lap)) collect func)) (defun comp-spill-lap (input) @@ -1415,7 +1418,7 @@ If INPUT is a string, use it as the file path to be native compiled." (symbol-name input) (file-name-sans-extension input))))) (mapc (lambda (pass) - (comp-log (format "\nRunning pass %s: " pass)) + (comp-log (format "Running pass %s:\n" pass)) (setq data (funcall pass data))) comp-passes))) commit 0a014a386200532d92974d255b0b3f6b33d07a22 Author: Andrea Corallo Date: Sat Sep 21 17:18:57 2019 +0200 rework lap spilling diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 77cd408ce9..1666dff711 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -565,8 +565,12 @@ Each element is (INDEX . VALUE)") ;; These are use by comp.el to spill data out of here (defvar byte-native-compiling nil) -(defvar byte-to-native-last-lap nil) -(defvar byte-to-native-output nil) +(defvar byte-to-native-lap nil + "Alist to accumulate lap. +Each element is (NAME . LAP)") +(defvar byte-to-native-bytecode nil + "Alist to accumulate bytecode. +Each element is (NAME . BYTECODE)") (defvar byte-to-native-top-level-forms nil) @@ -2273,8 +2277,9 @@ QUOTED says that we have to put a quote before the list that represents a doc string reference. `defvaralias', `autoload' and `custom-declare-variable' need that." (when byte-native-compiling - ;; Spill output for the native compiler here - (push (list name byte-to-native-last-lap (apply #'vector form)) byte-to-native-output)) + ;; Spill bytecode output for the native compiler here + (push (cons name (apply #'vector form)) + byte-to-native-bytecode)) ;; We need to examine byte-compile-dynamic-docstrings ;; in the input buffer (now current), not in the output buffer. (let ((dynamic-docstrings byte-compile-dynamic-docstrings)) @@ -2377,7 +2382,8 @@ list that represents a doc string reference. (defun byte-compile-flush-pending () (if byte-compile-output - (let ((form (byte-compile-out-toplevel t 'file))) + (let* ((byte-compile-current-form nil) + (form (byte-compile-out-toplevel t 'file))) (cond ((eq (car-safe form) 'progn) (mapc 'byte-compile-output-file-form (cdr form))) (form @@ -3128,8 +3134,10 @@ for symbols generated by the byte compiler itself." (out (list 'byte-code (byte-compile-lapcode byte-compile-output) byte-compile-vector byte-compile-maxdepth))) (when byte-native-compiling - ;; Spill output for the native compiler here - (setq byte-to-native-last-lap byte-compile-output)) + ;; Spill LAP for the native compiler here + (when byte-compile-current-form + (push (cons byte-compile-current-form byte-compile-output) + byte-to-native-lap))) out)) ;; it's a trivial function ((cdr body) (cons 'progn (nreverse body))) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 1ca086659a..e1e0858985 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -351,13 +351,15 @@ Put PREFIX in front of it." (error "Can't native compile an already bytecompiled function")) (setf (comp-func-byte-func func) (byte-compile (comp-func-symbol-name func))) - (comp-log byte-to-native-last-lap) - (let ((lambda-list (aref (comp-func-byte-func func) 0))) - (setf (comp-func-args func) - (comp-decrypt-lambda-list lambda-list))) - (setf (comp-func-lap func) byte-to-native-last-lap) - (setf (comp-func-frame-size func) (aref (comp-func-byte-func func) 3)) - func)) + (let ((lap (cdr (assoc function-name (reverse byte-to-native-bytecode))))) + (cl-assert lap) + (comp-log lap) + (let ((lambda-list (aref (comp-func-byte-func func) 0))) + (setf (comp-func-args func) + (comp-decrypt-lambda-list lambda-list))) + (setf (comp-func-lap func) lap) + (setf (comp-func-frame-size func) (aref (comp-func-byte-func func) 3)) + func))) (defun comp-spill-lap-functions-file (filename) "Byte compile FILENAME spilling data from the byte compiler." @@ -368,7 +370,11 @@ Put PREFIX in front of it." ('defvar (cdr x)) ('defconst (cdr x)))) byte-to-native-top-level-forms))) - (cl-loop for (name lap bytecode) in byte-to-native-output + ;; Hacky! We need to reverse `byte-to-native-lap' to have the compiled top + ;; level form that matters (ex exclude lambdas)... + (cl-loop with lap-funcs = byte-to-native-lap + for (name . bytecode) in byte-to-native-bytecode + for lap = (cdr (assoc name lap-funcs)) for lambda-list = (aref bytecode 0) for func = (make-comp-func :symbol-name name :byte-func bytecode @@ -386,8 +392,8 @@ Put PREFIX in front of it." If INPUT is a symbol this is the function-name to be compiled. If INPUT is a string this is the file path to be compiled." (let ((byte-native-compiling t) - (byte-to-native-last-lap nil) - (byte-to-native-output ()) + (byte-to-native-lap ()) + (byte-to-native-bytecode ()) (byte-to-native-top-level-forms ())) (cl-typecase input (symbol (list (comp-spill-lap-function input))) commit 82778374fef72583ac7c64f96187f56b1641ddea Author: Andrea Corallo Date: Sat Sep 21 14:06:13 2019 +0200 better log output diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index e94f3185b4..1ca086659a 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -285,7 +285,7 @@ BODY is evaluate only if `comp-debug' is non nil." (defun comp-log-func (func) "Log function FUNC." - (comp-log (format "\n\n Function: %s" (comp-func-symbol-name func))) + (comp-log (format "\n Function: %s" (comp-func-symbol-name func))) (cl-loop for block-name being each hash-keys of (comp-func-blocks func) using (hash-value bb) do (progn @@ -1409,6 +1409,7 @@ If INPUT is a string, use it as the file path to be native compiled." (symbol-name input) (file-name-sans-extension input))))) (mapc (lambda (pass) + (comp-log (format "\nRunning pass %s: " pass)) (setq data (funcall pass data))) comp-passes))) commit 10d7284a2a1e8a543b31e5c99c2fc0c26c8eb681 Author: Andrea Corallo Date: Sat Sep 21 11:38:40 2019 +0200 add missing arguments if missing in comp-call-optim-form-call diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 3ccdf4f2e4..e94f3185b4 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1303,27 +1303,39 @@ This can run just once." (defun comp-call-optim-form-call (callee args self) "" - (when (symbolp callee) ; Do nothing if callee is a byte compiled func. - (let* ((f (symbol-function callee)) - (subrp (subrp f)) - (callee-in-unit (gethash callee - (comp-ctxt-funcs-h comp-ctxt)))) - (if (and subrp (not (subr-native-elispp f))) - (let ((call-type (if (if subrp - (not (numberp (cdr (subr-arity f)))) - (comp-nargs-p callee-in-unit)) - 'callref - 'call))) - (comp-add-subr-to-relocs callee) - `(,call-type ,callee ,@args)) - ;; Intra compilation unit procedure call optimization. - (when (or (eq callee self) - ;; Attention speed 3 triggers that for non self calls too!! - (and (>= comp-speed 3) - callee-in-unit)) - (let* ((nargs (comp-nargs-p (comp-func-args callee-in-unit))) - (call-type (if nargs 'direct-callref 'direct-call))) - `(,call-type ,callee ,@args))))))) + (cl-flet ((fill-args (args total) + ;; Fill missing args to reach TOTAL + (append args (cl-loop repeat (- total (length args)) + collect (make-comp-mvar :constant nil))))) + (when (symbolp callee) ; Do nothing if callee is a byte compiled func. + (let* ((f (symbol-function callee)) + (subrp (subrp f)) + (callee-in-unit (gethash callee + (comp-ctxt-funcs-h comp-ctxt)))) + (if (and subrp (not (subr-native-elispp f))) + (let* ((maxarg (cdr (subr-arity f))) + (call-type (if (if subrp + (not (numberp maxarg)) + (comp-nargs-p callee-in-unit)) + 'callref + 'call)) + (args (if (eq call-type 'callref) + args + (fill-args args maxarg)))) + (comp-add-subr-to-relocs callee) + `(,call-type ,callee ,@args)) + ;; Intra compilation unit procedure call optimization. + (when (or (eq callee self) + ;; Attention speed 3 triggers that for non self calls too!! + (and (>= comp-speed 3) + callee-in-unit)) + (let* ((func-args (comp-func-args callee-in-unit)) + (nargs (comp-nargs-p func-args)) + (call-type (if nargs 'direct-callref 'direct-call)) + (args (if (eq call-type 'direct-callref) + args + (fill-args args (comp-args-max func-args))))) + `(,call-type ,callee ,@args)))))))) (defun comp-call-optim (funcs) "Given FUNCS try to avoid funcall trampoline usage when possible." commit baf16746960ad5f7baaf21b44feff9c8f3a4fc29 Author: Andrea Corallo Date: Sat Sep 21 11:36:48 2019 +0200 better error signaling when compilation fails diff --git a/src/comp.c b/src/comp.c index e0c332c89e..b25013d65a 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1299,7 +1299,7 @@ emit_limple_insn (Lisp_Object insn) else ice ("LIMPLE inconsistent arg1 for op ="); - ICE_IF (!res, "incoherent insn"); + ICE_IF (!res, gcc_jit_context_get_first_error (comp.ctxt)); gcc_jit_block_add_assignment (comp.block, NULL, commit 2fb2862facf3eb70897a2e5ba342971ce696bc5d Author: Andrea Corallo Date: Sat Sep 21 10:36:53 2019 +0200 cleanup unnecessary code and allow inlining at speed 3 diff --git a/src/comp.c b/src/comp.c index 89eead5c6c..e0c332c89e 100644 --- a/src/comp.c +++ b/src/comp.c @@ -2820,9 +2820,6 @@ DEFUN ("comp--init-ctxt", Fcomp__init_ctxt, Scomp__init_ctxt, } - /* Do not inline within a compilation unit. */ - gcc_jit_context_add_command_line_option (comp.ctxt, "-fno-inline"); - comp.void_type = gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_VOID); comp.void_ptr_type = gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_VOID_PTR); commit bbf8b1df90f327a74423b2ccbfe557da9b04dd9d Author: Andrea Corallo Date: Sat Sep 21 10:23:18 2019 +0200 add direct-call direct-callref support into the backend diff --git a/src/comp.c b/src/comp.c index 0365f0e09e..89eead5c6c 100644 --- a/src/comp.c +++ b/src/comp.c @@ -390,14 +390,14 @@ emit_call (Lisp_Object subr_sym, gcc_jit_type *ret_type, unsigned nargs, static gcc_jit_rvalue * emit_call_ref (Lisp_Object subr_sym, unsigned nargs, - gcc_jit_lvalue *base_arg) + gcc_jit_lvalue *base_arg, bool direct) { gcc_jit_rvalue *args[] = { gcc_jit_context_new_rvalue_from_int(comp.ctxt, comp.ptrdiff_type, nargs), gcc_jit_lvalue_get_address (base_arg, NULL) }; - return emit_call (subr_sym, comp.lisp_obj_type, 2, args, false); + return emit_call (subr_sym, comp.lisp_obj_type, 2, args, direct); } /* Close current basic block emitting a conditional. */ @@ -1054,7 +1054,7 @@ emit_set_internal (Lisp_Object args) /* This is for a regular function with arguments as m-var. */ static gcc_jit_rvalue * -emit_simple_limple_call (Lisp_Object args, gcc_jit_type *ret_type) +emit_simple_limple_call (Lisp_Object args, gcc_jit_type *ret_type, bool direct) { USE_SAFE_ALLOCA; int i = 0; @@ -1066,25 +1066,23 @@ emit_simple_limple_call (Lisp_Object args, gcc_jit_type *ret_type) gcc_args[i++] = emit_mvar_val (XCAR (args)); SAFE_FREE (); - return emit_call (callee, ret_type, nargs, gcc_args, false); + return emit_call (callee, ret_type, nargs, gcc_args, direct); } static gcc_jit_rvalue * emit_simple_limple_call_lisp_ret (Lisp_Object args) { /* - Ex: (call Fcar #s(comp-mvar 4 0 nil nil nil)) - Ex: (call Fcons #s(comp-mvar 3 0 t 1 nil) #s(comp-mvar 4 nil t nil nil)) */ - return emit_simple_limple_call (args, comp.lisp_obj_type); + return emit_simple_limple_call (args, comp.lisp_obj_type, false); } static gcc_jit_rvalue * emit_simple_limple_call_void_ret (Lisp_Object args) { - return emit_simple_limple_call (args, comp.void_type); + return emit_simple_limple_call (args, comp.void_type, false); } /* Entry point to dispatch emitting (call fun ...). */ @@ -1105,7 +1103,7 @@ emit_limple_call (Lisp_Object insn) } static gcc_jit_rvalue * -emit_limple_call_ref (Lisp_Object insn) +emit_limple_call_ref (Lisp_Object insn, bool direct) { /* Ex: (callref < #s(comp-mvar 1 6 nil nil nil t) #s(comp-mvar 2 11 t 10 integer t)). */ @@ -1113,7 +1111,7 @@ emit_limple_call_ref (Lisp_Object insn) Lisp_Object callee = FIRST (insn); EMACS_UINT nargs = XFIXNUM (Flength (CDR (insn))); EMACS_UINT base_ptr = XFIXNUM (FUNCALL1 (comp-mvar-slot, SECOND (insn))); - return emit_call_ref (callee, nargs, comp.frame[base_ptr]); + return emit_call_ref (callee, nargs, comp.frame[base_ptr], false); } /* Register an handler for a non local exit. */ @@ -1290,11 +1288,14 @@ emit_limple_insn (Lisp_Object insn) if (EQ (Ftype_of (arg1), Qcomp_mvar)) res = emit_mvar_val (arg1); - /* FIXME: should recurr here */ else if (EQ (FIRST (arg1), Qcall)) res = emit_limple_call (XCDR (arg1)); else if (EQ (FIRST (arg1), Qcallref)) - res = emit_limple_call_ref (XCDR (arg1)); + res = emit_limple_call_ref (XCDR (arg1), false); + else if (EQ (FIRST (arg1), Qdirect_call)) + res = emit_simple_limple_call (XCDR (arg1), comp.lisp_obj_type, true); + else if (EQ (FIRST (arg1), Qcallref)) + res = emit_limple_call_ref (XCDR (arg1), true); else ice ("LIMPLE inconsistent arg1 for op ="); @@ -2479,7 +2480,7 @@ define_negate (void) emit_make_fixnum (inline_res)); comp.block = fcall_block; - gcc_jit_rvalue *call_res = emit_call_ref (Qminus, 1, n); + gcc_jit_rvalue *call_res = emit_call_ref (Qminus, 1, n, false); gcc_jit_block_end_with_return (fcall_block, NULL, call_res); commit d87d9e41f5890fbe7d279053c9c7328890c94b2f Author: Andrea Corallo Date: Sat Sep 21 10:07:26 2019 +0200 extend emit_call to perform direct calls diff --git a/src/comp.c b/src/comp.c index a29e56203d..0365f0e09e 100644 --- a/src/comp.c +++ b/src/comp.c @@ -353,27 +353,39 @@ declare_imported_func (Lisp_Object subr_sym, gcc_jit_type *ret_type, return field; } +/* Emit calls fetching from existing declarations. */ static gcc_jit_rvalue * emit_call (Lisp_Object subr_sym, gcc_jit_type *ret_type, unsigned nargs, - gcc_jit_rvalue **args) + gcc_jit_rvalue **args, bool direct) { - Lisp_Object value = Fgethash (subr_sym, comp.imported_funcs_h, Qnil); - ICE_IF (NILP (value), "missing function declaration"); + Lisp_Object func = + Fgethash (subr_sym, direct ? comp.exported_funcs_h: comp.imported_funcs_h, + Qnil); + ICE_IF (NILP (func), "missing function declaration"); - gcc_jit_lvalue *f_ptr = - gcc_jit_lvalue_access_field (comp.func_relocs, - NULL, - (gcc_jit_field *) xmint_pointer (value)); - - ICE_IF (!f_ptr, "undeclared function relocation"); - - emit_comment (format_string ("calling subr: %s", - SSDATA (SYMBOL_NAME (subr_sym)))); - return gcc_jit_context_new_call_through_ptr(comp.ctxt, - NULL, - gcc_jit_lvalue_as_rvalue (f_ptr), - nargs, - args); + if (direct) + { + emit_comment (format_string ("direct call to subr: %s", + SSDATA (SYMBOL_NAME (subr_sym)))); + return gcc_jit_context_new_call (comp.ctxt, + NULL, + xmint_pointer (func), + nargs, + args); + } else { + gcc_jit_lvalue *f_ptr = + gcc_jit_lvalue_access_field (comp.func_relocs, + NULL, + (gcc_jit_field *) xmint_pointer (func)); + ICE_IF (!f_ptr, "undeclared function relocation"); + emit_comment (format_string ("calling subr: %s", + SSDATA (SYMBOL_NAME (subr_sym)))); + return gcc_jit_context_new_call_through_ptr (comp.ctxt, + NULL, + gcc_jit_lvalue_as_rvalue (f_ptr), + nargs, + args); + } } static gcc_jit_rvalue * @@ -385,7 +397,7 @@ emit_call_ref (Lisp_Object subr_sym, unsigned nargs, comp.ptrdiff_type, nargs), gcc_jit_lvalue_get_address (base_arg, NULL) }; - return emit_call (subr_sym, comp.lisp_obj_type, 2, args); + return emit_call (subr_sym, comp.lisp_obj_type, 2, args, false); } /* Close current basic block emitting a conditional. */ @@ -1036,7 +1048,7 @@ emit_set_internal (Lisp_Object args) comp.int_type, SET_INTERNAL_SET); return emit_call (intern_c_string ("set_internal"), comp.void_type , 4, - gcc_args); + gcc_args, false); } /* This is for a regular function with arguments as m-var. */ @@ -1054,7 +1066,7 @@ emit_simple_limple_call (Lisp_Object args, gcc_jit_type *ret_type) gcc_args[i++] = emit_mvar_val (XCAR (args)); SAFE_FREE (); - return emit_call (callee, ret_type, nargs, gcc_args); + return emit_call (callee, ret_type, nargs, gcc_args, false); } static gcc_jit_rvalue * @@ -1128,7 +1140,8 @@ emit_limple_push_handler (gcc_jit_rvalue *handler, gcc_jit_rvalue *handler_type, comp.block, NULL, c, - emit_call (intern_c_string ("push_handler"), comp.handler_ptr_type, 2, args)); + emit_call (intern_c_string ("push_handler"), + comp.handler_ptr_type, 2, args, false)); args[0] = gcc_jit_lvalue_get_address ( @@ -1139,7 +1152,8 @@ emit_limple_push_handler (gcc_jit_rvalue *handler, gcc_jit_rvalue *handler_type, NULL); gcc_jit_rvalue *res; - res = emit_call (intern_c_string (SETJMP_NAME), comp.int_type, 1, args); + res = + emit_call (intern_c_string (SETJMP_NAME), comp.int_type, 1, args, false); emit_cond_jump (res, handler_bb, guarded_bb); /* This emit the handler part. */ @@ -1276,6 +1290,7 @@ emit_limple_insn (Lisp_Object insn) if (EQ (Ftype_of (arg1), Qcomp_mvar)) res = emit_mvar_val (arg1); + /* FIXME: should recurr here */ else if (EQ (FIRST (arg1), Qcall)) res = emit_limple_call (XCDR (arg1)); else if (EQ (FIRST (arg1), Qcallref)) @@ -1349,7 +1364,7 @@ emit_limple_insn (Lisp_Object insn) gcc_jit_lvalue_as_rvalue (args) }; res = emit_call (Qlist, comp.lisp_obj_type, 2, - list_args); + list_args, false); gcc_jit_block_add_assignment (comp.block, NULL, @@ -2158,7 +2173,8 @@ define_CHECK_TYPE (void) gcc_jit_block_add_eval (comp.block, NULL, emit_call (intern_c_string ("wrong_type_argument"), - comp.void_type, 2, wrong_type_args)); + comp.void_type, 2, wrong_type_args, + false)); gcc_jit_block_end_with_void_return (not_ok_block, NULL); } @@ -2240,7 +2256,8 @@ define_CAR_CDR (void) gcc_jit_block_add_eval (comp.block, NULL, emit_call (intern_c_string ("wrong_type_argument"), - comp.void_type, 2, wrong_type_args)); + comp.void_type, 2, wrong_type_args, + false)); gcc_jit_block_end_with_return (comp.block, NULL, emit_const_lisp_obj (Qnil)); @@ -2389,7 +2406,7 @@ define_add1_sub1 (void) comp.block = fcall_block; gcc_jit_rvalue *call_res = emit_call (intern_c_string (fall_back_func[i]), - comp.lisp_obj_type, 1, &n); + comp.lisp_obj_type, 1, &n, false); gcc_jit_block_end_with_return (fcall_block, NULL, call_res); @@ -2521,9 +2538,7 @@ define_PSEUDOVECTORP (void) call_pseudovector_typep_b, NULL, emit_call (intern_c_string ("helper_PSEUDOVECTOR_TYPEP_XUNTAG"), - comp.bool_type, - 2, - args)); + comp.bool_type, 2, args, false)); } static void @@ -2566,8 +2581,8 @@ define_CHECK_IMPURE (void) gcc_jit_block_add_eval (comp.block, NULL, emit_call (intern_c_string ("pure_write_error"), - comp.void_type, 1, - &pure_write_error_arg)); + comp.void_type, 1,&pure_write_error_arg, + false)); gcc_jit_block_end_with_void_return (err_block, NULL); } commit 89172ac4376403b987bad897cdcfd22f9e5d97c8 Author: Andrea Corallo Date: Sat Sep 21 09:48:15 2019 +0200 split declaration and compilation diff --git a/src/comp.c b/src/comp.c index ed658ee5b3..a29e56203d 100644 --- a/src/comp.c +++ b/src/comp.c @@ -147,7 +147,6 @@ typedef struct { gcc_jit_field *cast_union_as_lisp_obj; gcc_jit_field *cast_union_as_lisp_obj_ptr; gcc_jit_function *func; /* Current function being compiled. */ - Lisp_Object lfunc; gcc_jit_block *block; /* Current basic block being compiled. */ gcc_jit_lvalue **frame; /* Frame for the current function. */ gcc_jit_rvalue *most_positive_fixnum; @@ -166,8 +165,9 @@ typedef struct { gcc_jit_function *setcdr; gcc_jit_function *check_type; gcc_jit_function *check_impure; - Lisp_Object func_blocks; /* blk_name -> gcc_block. */ - Lisp_Object imported_func_h; /* subr_name -> reloc_field. */ + Lisp_Object func_blocks_h; /* blk_name -> gcc_block. */ + Lisp_Object exported_funcs_h; /* subr_name -> gcc_jit_function *. */ + Lisp_Object imported_funcs_h; /* subr_name -> reloc_field. */ Lisp_Object emitter_dispatcher; gcc_jit_rvalue *data_relocs; /* Synthesized struct holding data relocs. */ gcc_jit_lvalue *func_relocs; /* Synthesized struct holding func relocs. */ @@ -265,7 +265,7 @@ type_to_cast_field (gcc_jit_type *type) static gcc_jit_block * retrive_block (Lisp_Object block_name) { - Lisp_Object value = Fgethash (block_name, comp.func_blocks, Qnil); + Lisp_Object value = Fgethash (block_name, comp.func_blocks_h, Qnil); ICE_IF (NILP (value), "missing basic block"); return (gcc_jit_block *) xmint_pointer (value); @@ -277,9 +277,9 @@ declare_block (Lisp_Object block_name) char *name_str = (char *) SDATA (SYMBOL_NAME (block_name)); gcc_jit_block *block = gcc_jit_function_new_block (comp.func, name_str); Lisp_Object value = make_mint_ptr (block); - ICE_IF (!NILP (Fgethash (block_name, comp.func_blocks, Qnil)), + ICE_IF (!NILP (Fgethash (block_name, comp.func_blocks_h, Qnil)), "double basic block declaration"); - Fputhash (block_name, value, comp.func_blocks); + Fputhash (block_name, value, comp.func_blocks_h); } static void @@ -308,7 +308,7 @@ declare_imported_func (Lisp_Object subr_sym, gcc_jit_type *ret_type, int nargs, gcc_jit_type **types) { /* Don't want to declare the same function two times. */ - ICE_IF (!NILP (Fgethash (subr_sym, comp.imported_func_h, Qnil)), + ICE_IF (!NILP (Fgethash (subr_sym, comp.imported_funcs_h, Qnil)), "unexpected double function declaration"); if (nargs == MANY) @@ -349,63 +349,15 @@ declare_imported_func (Lisp_Object subr_sym, gcc_jit_type *ret_type, f_ptr_type, SSDATA (f_ptr_name)); - Fputhash (subr_sym, make_mint_ptr (field), comp.imported_func_h); + Fputhash (subr_sym, make_mint_ptr (field), comp.imported_funcs_h); return field; } -static void -fill_declaration_types (gcc_jit_type **type, gcc_jit_rvalue **args, - unsigned nargs) -{ - /* If args are passed types are extracted from that otherwise assume params */ - /* are all lisp objs. */ - if (args) - for (unsigned i = 0; i < nargs; i++) - type[i] = gcc_jit_rvalue_get_type (args[i]); - else - for (unsigned i = 0; i < nargs; i++) - type[i] = comp.lisp_obj_type; -} - -static gcc_jit_function * -declare_exported_func (const char *f_name, gcc_jit_type *ret_type, - unsigned nargs, gcc_jit_rvalue **args) -{ - USE_SAFE_ALLOCA; - gcc_jit_type **type = SAFE_ALLOCA (nargs * sizeof (*type)); - fill_declaration_types (type, args, nargs); - - gcc_jit_param **param = SAFE_ALLOCA (nargs *sizeof (*param)); - for (int i = nargs - 1; i >= 0; i--) - param[i] = gcc_jit_context_new_param(comp.ctxt, - NULL, - type[i], - format_string ("par_%d", i)); - SAFE_FREE (); - return gcc_jit_context_new_function(comp.ctxt, NULL, - GCC_JIT_GLOBAL_EXPORTED, - ret_type, - f_name, - nargs, - param, - 0); -} - static gcc_jit_rvalue * emit_call (Lisp_Object subr_sym, gcc_jit_type *ret_type, unsigned nargs, gcc_jit_rvalue **args) { - /* Self call optimization. */ - if (!NILP (comp.lfunc) && - comp_speed >= 2 && - EQ (subr_sym, FUNCALL1 (comp-func-symbol-name, comp.lfunc))) - return gcc_jit_context_new_call (comp.ctxt, - NULL, - comp.func, - nargs, - args); - - Lisp_Object value = Fgethash (subr_sym, comp.imported_func_h, Qnil); + Lisp_Object value = Fgethash (subr_sym, comp.imported_funcs_h, Qnil); ICE_IF (NILP (value), "missing function declaration"); gcc_jit_lvalue *f_ptr = @@ -2660,22 +2612,36 @@ define_bool_to_lisp_obj (void) } +/* Declare a function being compiled and add it to comp.exported_funcs_h. */ static void -compile_function (Lisp_Object func) +declare_function (Lisp_Object func) { - USE_SAFE_ALLOCA; + gcc_jit_function *gcc_func; char *c_name = SSDATA (FUNCALL1 (comp-func-c-func-name, func)); Lisp_Object args = FUNCALL1 (comp-func-args, func); - EMACS_INT frame_size = XFIXNUM (FUNCALL1 (comp-func-frame-size, func)); bool ncall = (FUNCALL1 (comp-nargs-p, args)); - - comp.lfunc = func; + USE_SAFE_ALLOCA; if (!ncall) { EMACS_INT max_args = XFIXNUM (FUNCALL1 (comp-args-max, args)); - comp.func - = declare_exported_func (c_name, comp.lisp_obj_type, max_args, NULL); + gcc_jit_type **type = SAFE_ALLOCA (max_args * sizeof (*type)); + for (unsigned i = 0; i < max_args; i++) + type[i] = comp.lisp_obj_type; + + gcc_jit_param **param = SAFE_ALLOCA (max_args *sizeof (*param)); + for (int i = max_args - 1; i >= 0; i--) + param[i] = gcc_jit_context_new_param (comp.ctxt, + NULL, + type[i], + format_string ("par_%d", i)); + gcc_func = gcc_jit_context_new_function (comp.ctxt, NULL, + GCC_JIT_GLOBAL_EXPORTED, + comp.lisp_obj_type, + c_name, + max_args, + param, + 0); } else { @@ -2688,7 +2654,7 @@ compile_function (Lisp_Object func) NULL, comp.lisp_obj_ptr_type, "args") }; - comp.func = + gcc_func = gcc_jit_context_new_function (comp.ctxt, NULL, GCC_JIT_FUNCTION_EXPORTED, @@ -2696,6 +2662,22 @@ compile_function (Lisp_Object func) c_name, 2, param, 0); } + Fputhash (FUNCALL1 (comp-func-symbol-name, func), + make_mint_ptr (gcc_func), + comp.exported_funcs_h); + + SAFE_FREE (); +} + +static void +compile_function (Lisp_Object func) +{ + USE_SAFE_ALLOCA; + EMACS_INT frame_size = XFIXNUM (FUNCALL1 (comp-func-frame-size, func)); + + comp.func = xmint_pointer (Fgethash (FUNCALL1 (comp-func-symbol-name, func), + comp.exported_funcs_h, Qnil)); + gcc_jit_lvalue *frame_array = gcc_jit_function_new_local ( comp.func, @@ -2717,7 +2699,7 @@ compile_function (Lisp_Object func) comp.int_type, i)); - comp.func_blocks = CALLN (Fmake_hash_table); + comp.func_blocks_h = CALLN (Fmake_hash_table); /* Pre declare all basic blocks to gcc. The "entry" block must be declared as first. */ @@ -2752,7 +2734,6 @@ compile_function (Lisp_Object func) format_string ("failing to compile function %s with error: %s", SSDATA (SYMBOL_NAME (FUNCALL1 (comp-func-symbol-name, func))), err)); - comp.lfunc = Qnil; SAFE_FREE (); } @@ -2906,11 +2887,12 @@ DEFUN ("comp--init-ctxt", Fcomp__init_ctxt, Scomp__init_ctxt, sizeof (void *), false); + comp.exported_funcs_h = CALLN (Fmake_hash_table); /* Always reinitialize this cause old function definitions are garbage collected by libgccjit when the ctxt is released. */ - comp.imported_func_h = CALLN (Fmake_hash_table); + comp.imported_funcs_h = CALLN (Fmake_hash_table); /* Define data structures. */ @@ -2983,6 +2965,8 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, relocation structs has to be already defined. */ struct Lisp_Hash_Table *func_h = XHASH_TABLE (FUNCALL1 (comp-ctxt-funcs-h, Vcomp_ctxt)); + for (ptrdiff_t i = 0; i < func_h->count; i++) + declare_function (HASH_VALUE (func_h, i)); for (ptrdiff_t i = 0; i < func_h->count; i++) compile_function (HASH_VALUE (func_h, i)); @@ -3220,6 +3204,8 @@ syms_of_comp (void) DEFSYM (Qjump, "jump"); DEFSYM (Qcall, "call"); DEFSYM (Qcallref, "callref"); + DEFSYM (Qdirect_call, "direct-call"); + DEFSYM (Qdirect_callref, "direct-callref"); DEFSYM (Qncall, "ncall"); DEFSYM (Qsetimm, "setimm"); DEFSYM (Qreturn, "return"); @@ -3265,9 +3251,11 @@ syms_of_comp (void) defsubr (&Scomp__compile_ctxt_to_file); defsubr (&Snative_elisp_load); - staticpro (&comp.imported_func_h); - comp.imported_func_h = Qnil; - staticpro (&comp.func_blocks); + staticpro (&comp.exported_funcs_h); + comp.exported_funcs_h = Qnil; + staticpro (&comp.imported_funcs_h); + comp.imported_funcs_h = Qnil; + staticpro (&comp.func_blocks_h); staticpro (&comp.emitter_dispatcher); comp.emitter_dispatcher = Qnil; commit c31b471cadcb9b8171de04b09a044bb775682a3a Author: Andrea Corallo Date: Sat Sep 21 09:47:02 2019 +0200 add direct-call direct-callref into frontend diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 551fdf8038..3ccdf4f2e4 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1308,20 +1308,22 @@ This can run just once." (subrp (subrp f)) (callee-in-unit (gethash callee (comp-ctxt-funcs-h comp-ctxt)))) - (when-let* ((optimize (or (and subrp - (not (subr-native-elispp f))) - (eq callee self) - ;; Attention speed 3 optimize inter compilation - ;; unit calls!! - (and (>= comp-speed 3) - callee-in-unit))) - (call-type (if (if subrp - (not (numberp (cdr (subr-arity f)))) - (comp-nargs-p callee-in-unit)) - 'callref - 'call))) - (comp-add-subr-to-relocs callee) - `(,call-type ,callee ,@args))))) + (if (and subrp (not (subr-native-elispp f))) + (let ((call-type (if (if subrp + (not (numberp (cdr (subr-arity f)))) + (comp-nargs-p callee-in-unit)) + 'callref + 'call))) + (comp-add-subr-to-relocs callee) + `(,call-type ,callee ,@args)) + ;; Intra compilation unit procedure call optimization. + (when (or (eq callee self) + ;; Attention speed 3 triggers that for non self calls too!! + (and (>= comp-speed 3) + callee-in-unit)) + (let* ((nargs (comp-nargs-p (comp-func-args callee-in-unit))) + (call-type (if nargs 'direct-callref 'direct-call))) + `(,call-type ,callee ,@args))))))) (defun comp-call-optim (funcs) "Given FUNCS try to avoid funcall trampoline usage when possible." commit 4088e467b3be3fcf6a1813bc74de7c4d3c193f1f Author: Andrea Corallo Date: Thu Sep 19 14:55:44 2019 +0200 better naming func_hash -> imported_func_h diff --git a/src/comp.c b/src/comp.c index 9cdb35f110..ed658ee5b3 100644 --- a/src/comp.c +++ b/src/comp.c @@ -167,7 +167,7 @@ typedef struct { gcc_jit_function *check_type; gcc_jit_function *check_impure; Lisp_Object func_blocks; /* blk_name -> gcc_block. */ - Lisp_Object func_hash; /* subr_name -> reloc_field. */ + Lisp_Object imported_func_h; /* subr_name -> reloc_field. */ Lisp_Object emitter_dispatcher; gcc_jit_rvalue *data_relocs; /* Synthesized struct holding data relocs. */ gcc_jit_lvalue *func_relocs; /* Synthesized struct holding func relocs. */ @@ -308,7 +308,7 @@ declare_imported_func (Lisp_Object subr_sym, gcc_jit_type *ret_type, int nargs, gcc_jit_type **types) { /* Don't want to declare the same function two times. */ - ICE_IF (!NILP (Fgethash (subr_sym, comp.func_hash, Qnil)), + ICE_IF (!NILP (Fgethash (subr_sym, comp.imported_func_h, Qnil)), "unexpected double function declaration"); if (nargs == MANY) @@ -349,7 +349,7 @@ declare_imported_func (Lisp_Object subr_sym, gcc_jit_type *ret_type, f_ptr_type, SSDATA (f_ptr_name)); - Fputhash (subr_sym, make_mint_ptr (field), comp.func_hash); + Fputhash (subr_sym, make_mint_ptr (field), comp.imported_func_h); return field; } @@ -405,7 +405,7 @@ emit_call (Lisp_Object subr_sym, gcc_jit_type *ret_type, unsigned nargs, nargs, args); - Lisp_Object value = Fgethash (subr_sym, comp.func_hash, Qnil); + Lisp_Object value = Fgethash (subr_sym, comp.imported_func_h, Qnil); ICE_IF (NILP (value), "missing function declaration"); gcc_jit_lvalue *f_ptr = @@ -2910,7 +2910,7 @@ DEFUN ("comp--init-ctxt", Fcomp__init_ctxt, Scomp__init_ctxt, Always reinitialize this cause old function definitions are garbage collected by libgccjit when the ctxt is released. */ - comp.func_hash = CALLN (Fmake_hash_table); + comp.imported_func_h = CALLN (Fmake_hash_table); /* Define data structures. */ @@ -3265,8 +3265,8 @@ syms_of_comp (void) defsubr (&Scomp__compile_ctxt_to_file); defsubr (&Snative_elisp_load); - staticpro (&comp.func_hash); - comp.func_hash = Qnil; + staticpro (&comp.imported_func_h); + comp.imported_func_h = Qnil; staticpro (&comp.func_blocks); staticpro (&comp.emitter_dispatcher); comp.emitter_dispatcher = Qnil; commit 8124ddf387451ec95ee4f8e0f726ab234bd8b762 Author: Andrea Corallo Date: Thu Sep 19 14:29:14 2019 +0200 dead code removal diff --git a/src/comp.c b/src/comp.c index ef10c466cf..9cdb35f110 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3008,62 +3008,6 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, return Qt; } -/* DEFUN ("comp-compile-and-load-ctxt", Fcomp_compile_and_load_ctxt, */ -/* Scomp_compile_and_load_ctxt, */ -/* 0, 1, 0, */ -/* doc: /\* Compile as native code the current context and load its */ -/* functions. *\/) */ -/* (Lisp_Object disassemble) */ -/* { */ -/* gcc_jit_context_set_int_option (comp.ctxt, */ -/* GCC_JIT_INT_OPTION_OPTIMIZATION_LEVEL, */ -/* comp_speed); */ -/* /\* Gcc doesn't like being interrupted at all. *\/ */ -/* sigset_t oldset; */ -/* sigset_t blocked; */ -/* sigemptyset (&blocked); */ -/* sigaddset (&blocked, SIGALRM); */ -/* sigaddset (&blocked, SIGINT); */ -/* sigaddset (&blocked, SIGIO); */ -/* pthread_sigmask (SIG_BLOCK, &blocked, &oldset); */ - -/* if (COMP_DEBUG) */ -/* gcc_jit_context_dump_to_file (comp.ctxt, "gcc-ctxt-dump.c", 1); */ -/* gcc_jit_result *gcc_res = gcc_jit_context_compile(comp.ctxt); */ - -/* if (!NILP (disassemble)) */ -/* gcc_jit_context_compile_to_file (comp.ctxt, */ -/* GCC_JIT_OUTPUT_KIND_ASSEMBLER, */ -/* "gcc-ctxt-dump.s"); */ - -/* while (CONSP (comp.funcs)) */ -/* { */ -/* union Aligned_Lisp_Subr *x = xmalloc (sizeof (union Aligned_Lisp_Subr)); */ -/* Lisp_Object func = XCAR (comp.funcs); */ -/* Lisp_Object args = FUNCALL1 (comp-func-args, func); */ -/* char *symbol_name = */ -/* (char *) SDATA (SYMBOL_NAME (FUNCALL1 (comp-func-symbol-name, func))); */ -/* char *c_name = (char *) SDATA (FUNCALL1 (comp-func-c-func-name, func)); */ - -/* x->s.header.size = PVEC_SUBR << PSEUDOVECTOR_AREA_BITS; */ -/* x->s.function.a0 = gcc_jit_result_get_code(gcc_res, c_name); */ -/* eassert (x->s.function.a0); */ -/* x->s.min_args = XFIXNUM (FUNCALL1 (comp-args-base-min, args)); */ -/* if (FUNCALL1 (comp-args-p, args)) */ -/* x->s.max_args = XFIXNUM (FUNCALL1 (comp-args-max, args)); */ -/* else */ -/* x->s.max_args = MANY; */ -/* x->s.symbol_name = symbol_name; */ -/* defsubr(x); */ - -/* comp.funcs = XCDR (comp.funcs); */ -/* } */ - -/* pthread_sigmask (SIG_SETMASK, &oldset, 0); */ - -/* return Qt; */ -/* } */ - /******************************************************************************/ /* Helper functions called from the runtime. */ commit 2cd60cb592930d985565612e0f22766b98fcf341 Author: Andrea Corallo Date: Thu Sep 19 01:25:46 2019 +0200 guard comp-call-optim-form-call for byte compiled callee diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index ad64ee7618..551fdf8038 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1301,27 +1301,27 @@ This can run just once." ;;; Call optimizer pass specific code. ;; Try to avoid funcall trampoline use when possible. -(defun comp-call-optim-form-call (calle args self) +(defun comp-call-optim-form-call (callee args self) "" - (let* ((f (symbol-function calle)) - (subrp (subrp f)) - (calle-in-unit (gethash calle - (comp-ctxt-funcs-h comp-ctxt)))) - (when-let* ((optimize (or (and subrp - (or - (not (subr-native-elispp f))) - ;; Attention speed 3 optimize inter compilation unit - ;; calls!! -) - (eq calle self) - (and (>= comp-speed 3) - calle-in-unit))) - (call-type (if (if subrp - (not (numberp (cdr (subr-arity f)))) - (comp-nargs-p calle-in-unit)) - 'callref - 'call))) - `(,call-type ,calle ,@args)))) + (when (symbolp callee) ; Do nothing if callee is a byte compiled func. + (let* ((f (symbol-function callee)) + (subrp (subrp f)) + (callee-in-unit (gethash callee + (comp-ctxt-funcs-h comp-ctxt)))) + (when-let* ((optimize (or (and subrp + (not (subr-native-elispp f))) + (eq callee self) + ;; Attention speed 3 optimize inter compilation + ;; unit calls!! + (and (>= comp-speed 3) + callee-in-unit))) + (call-type (if (if subrp + (not (numberp (cdr (subr-arity f)))) + (comp-nargs-p callee-in-unit)) + 'callref + 'call))) + (comp-add-subr-to-relocs callee) + `(,call-type ,callee ,@args))))) (defun comp-call-optim (funcs) "Given FUNCS try to avoid funcall trampoline usage when possible." diff --git a/src/comp.c b/src/comp.c index ca22b81de1..ef10c466cf 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1048,7 +1048,7 @@ emit_mvar_val (Lisp_Object mvar) if (FIXNUMP (constant)) { /* We can still emit directly objects that are selfcontained in a word - read (fixnums). */ + (read fixnums). */ emit_comment (SSDATA (Fprin1_to_string (constant, Qnil))); gcc_jit_rvalue *word = gcc_jit_context_new_rvalue_from_ptr(comp.ctxt, commit 403a7e59d5c79d81ee018fd9e648a2af744211c1 Author: Andrea Corallo Date: Thu Sep 19 00:07:10 2019 +0200 fix compilation for comp.el diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 583a77815e..ad64ee7618 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -396,6 +396,34 @@ If INPUT is a string this is the file path to be compiled." ;;; Limplification pass specific code. +(defmacro comp-sp () + "Current stack pointer." + '(comp-limplify-sp comp-pass)) + +(defmacro comp-with-sp (sp &rest body) + "Execute BODY setting the stack pointer to SP. +Restore the original value afterwards." + (declare (debug (form body)) + (indent defun)) + (let ((sym (gensym))) + `(let ((,sym (comp-sp))) + (setf (comp-sp) ,sp) + (progn ,@body) + (setf (comp-sp) ,sym)))) + +(defmacro comp-slot-n (n) + "Slot N into the meta-stack." + (declare (debug (form))) + `(aref (comp-limplify-frame comp-pass) ,n)) + +(defmacro comp-slot () + "Current slot into the meta-stack pointed by sp." + '(comp-slot-n (comp-sp))) + +(defmacro comp-slot+1 () + "Slot into the meta-stack pointed by sp + 1." + '(comp-slot-n (1+ (comp-sp)))) + (cl-defstruct (comp-limplify (:copier nil)) "Support structure used during function limplification." (sp 0 :type fixnum @@ -445,34 +473,6 @@ If INPUT is a string this is the file path to be compiled." do (aset v i mvar) finally (return v))) -(defmacro comp-sp () - "Current stack pointer." - '(comp-limplify-sp comp-pass)) - -(defmacro comp-with-sp (sp &rest body) - "Execute BODY setting the stack pointer to SP. -Restore the original value afterwards." - (declare (debug (form body)) - (indent defun)) - (let ((sym (gensym))) - `(let ((,sym (comp-sp))) - (setf (comp-sp) ,sp) - (progn ,@body) - (setf (comp-sp) ,sym)))) - -(defmacro comp-slot-n (n) - "Slot N into the meta-stack." - (declare (debug (form))) - `(aref (comp-limplify-frame comp-pass) ,n)) - -(defmacro comp-slot () - "Current slot into the meta-stack pointed by sp." - '(comp-slot-n (comp-sp))) - -(defmacro comp-slot+1 () - "Slot into the meta-stack pointed by sp + 1." - '(comp-slot-n (1+ (comp-sp)))) - (defun comp-emit (insn) "Emit INSN into current basic block." (push insn (comp-block-insns comp-block))) @@ -1111,7 +1111,7 @@ Top level forms for the current context are rendered too." (cl-loop for insn in (comp-block-insns bb) when (and (comp-assign-op-p (car insn)) (= slot-n (comp-mvar-slot (cadr insn)))) - do (return t)))) + do (cl-return t)))) (cl-loop for i from 0 below (comp-func-frame-size comp-func) ;; List of blocks with a definition of mvar i commit a8d358ed231b7656be50b034484b498b0b222445 Author: Andrea Corallo Date: Wed Sep 18 23:25:37 2019 +0200 adding comp-call-optim pass diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 6463b02054..583a77815e 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -944,11 +944,18 @@ This will be called at runtime." (mapc #'comp-limplify-lap-inst (comp-func-lap func)) (comp-limplify-finalize-function func))) +(defun comp-add-func-to-ctxt (func) + "Add FUNC to the current compiler contex." + (puthash (comp-func-symbol-name func) + func + (comp-ctxt-funcs-h comp-ctxt))) + (defun comp-limplify (funcs) "Compute the LIMPLE ir for FUNCS. Top level forms for the current context are rendered too." - (cons (comp-limplify-top-level) - (mapcar #'comp-limplify-function funcs))) + (mapc #'comp-add-func-to-ctxt + (cons (comp-limplify-top-level) + (mapcar #'comp-limplify-function funcs)))) ;;; SSA pass specific code. @@ -1294,14 +1301,34 @@ This can run just once." ;;; Call optimizer pass specific code. ;; Try to avoid funcall trampoline use when possible. +(defun comp-call-optim-form-call (calle args self) + "" + (let* ((f (symbol-function calle)) + (subrp (subrp f)) + (calle-in-unit (gethash calle + (comp-ctxt-funcs-h comp-ctxt)))) + (when-let* ((optimize (or (and subrp + (or + (not (subr-native-elispp f))) + ;; Attention speed 3 optimize inter compilation unit + ;; calls!! +) + (eq calle self) + (and (>= comp-speed 3) + calle-in-unit))) + (call-type (if (if subrp + (not (numberp (cdr (subr-arity f)))) + (comp-nargs-p calle-in-unit)) + 'callref + 'call))) + `(,call-type ,calle ,@args)))) + (defun comp-call-optim (funcs) + "Given FUNCS try to avoid funcall trampoline usage when possible." (cl-loop for comp-func in funcs for self = (comp-func-symbol-name comp-func) - for self-callref = (comp-nargs-p (comp-func-args comp-func)) - when (and (>= comp-speed 2) - (not self-callref) ;; Could improve this - ) + when (>= comp-speed 2) do (cl-loop for b being each hash-value of (comp-func-blocks comp-func) do (cl-loop @@ -1309,9 +1336,13 @@ This can run just once." for insn = (car insn-cell) do (pcase insn (`(set ,lval (callref funcall ,f . ,rest)) - (when (eq self (comp-mvar-constant f)) - (setcar insn-cell - `(set ,lval (call ,(comp-mvar-constant f) ,@rest)))))))) + (when-let ((new-form (comp-call-optim-form-call + (comp-mvar-constant f) rest self))) + (setcar insn-cell `(set ,lval ,new-form)))) + (`(callref funcall ,f . ,rest) + (when-let ((new-form (comp-call-optim-form-call + (comp-mvar-constant f) rest self))) + (setcar insn-cell ,new-form)))))) (comp-log-func comp-func)) funcs) @@ -1338,21 +1369,13 @@ Prepare every functions for final compilation and drive the C side." doc))) (comp--compile-ctxt-to-file name)) -(defun comp-add-func-to-ctxt (func) - "Add FUNC to the current compiler contex." - (puthash (comp-func-symbol-name func) - func - (comp-ctxt-funcs-h comp-ctxt))) - -(defun comp-final (data) - "Final pass driving DATA into the C side for code emission." +(defun comp-final (_) + "Final pass driving DATA into the C back-end for code emission." (let (compile-result) (comp--init-ctxt) (unwind-protect - (progn - (mapc #'comp-add-func-to-ctxt data) - (setq compile-result - (comp-compile-ctxt-to-file (comp-ctxt-output comp-ctxt)))) + (setq compile-result + (comp-compile-ctxt-to-file (comp-ctxt-output comp-ctxt))) (and (comp--release-ctxt) compile-result)))) commit 9709ff1436d547664e6b3ca252cd37665467b4de Author: Andrea Corallo Date: Wed Sep 18 12:46:45 2019 +0200 add native_elisp field into Lisp_Subr diff --git a/src/comp.c b/src/comp.c index 8aadd5acc9..ca22b81de1 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3228,6 +3228,7 @@ load_comp_unit (dynlib_handle_ptr handle) x->s.min_args = minargs; x->s.max_args = maxargs; x->s.symbol_name = SSDATA (Fsymbol_name (Qsym)); + x->s.native_elisp = true; defsubr(x); func_list = XCDR (func_list); diff --git a/src/data.c b/src/data.c index 56e363f16b..70068c30a7 100644 --- a/src/data.c +++ b/src/data.c @@ -864,6 +864,17 @@ SUBR must be a built-in function. */) return build_string (name); } +#ifdef HAVE_NATIVE_COMP +DEFUN ("subr-native-elispp", Fsubr_native_elispp, Ssubr_native_elispp, 1, 1, 0, + doc: /* Return t if the subr is native compiled elisp, +nil otherwise. */) + (Lisp_Object subr) +{ + CHECK_SUBR (subr); + return XSUBR (subr)->native_elisp ? Qt : Qnil; +} +#endif + DEFUN ("interactive-form", Finteractive_form, Sinteractive_form, 1, 1, 0, doc: /* Return the interactive form of CMD or nil if none. If CMD is not a command, the return value is nil. @@ -3983,6 +3994,9 @@ syms_of_data (void) defsubr (&Sbyteorder); defsubr (&Ssubr_arity); defsubr (&Ssubr_name); +#ifdef HAVE_NATIVE_COMP + defsubr (&Ssubr_native_elispp); +#endif #ifdef HAVE_MODULES defsubr (&Suser_ptrp); #endif diff --git a/src/lisp.h b/src/lisp.h index cb3487675e..a84c08e566 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -2088,6 +2088,9 @@ struct Lisp_Subr const char *symbol_name; const char *intspec; EMACS_INT doc; +#ifdef HAVE_NATIVE_COMP + bool native_elisp; +#endif } GCALIGNED_STRUCT; union Aligned_Lisp_Subr { diff --git a/src/pdumper.c b/src/pdumper.c index 3ee1146040..7b3109607b 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -2922,7 +2922,10 @@ dump_bool_vector (struct dump_context *ctx, const struct Lisp_Vector *v) static dump_off dump_subr (struct dump_context *ctx, const struct Lisp_Subr *subr) { -#if CHECK_STRUCTS && !defined (HASH_Lisp_Subr_594AB72B54) +#if CHECK_STRUCTS && ((defined (HAVE_NATIVE_COMP) \ + && !defined (HASH_Lisp_Subr_D4F15794AF)) \ + || (!defined (HAVE_NATIVE_COMP) \ + && !defined (HASH_Lisp_Subr_594AB72B54))) # error "Lisp_Subr changed. See CHECK_STRUCTS comment in config.h." #endif struct Lisp_Subr out; @@ -2934,6 +2937,7 @@ dump_subr (struct dump_context *ctx, const struct Lisp_Subr *subr) dump_field_emacs_ptr (ctx, &out, subr, &subr->symbol_name); dump_field_emacs_ptr (ctx, &out, subr, &subr->intspec); DUMP_FIELD_COPY (&out, subr, doc); + DUMP_FIELD_COPY (&out, subr, native_elisp); return dump_object_finish (ctx, &out, sizeof (out)); } commit bd3cd579cb43ace253e245a7026b172f216f3a1f Author: Andrea Corallo Date: Wed Sep 18 11:55:25 2019 +0200 remove comp-emit-funcall diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 8f93efd73a..6463b02054 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -625,38 +625,6 @@ If NEGATED non nil negate the tested condition." do (comp-emit-cond-jump var m-test 0 target-label nil))) (_ (error "Missing previous setimm while creating a switch")))) -(defun comp-emit-funcall (narg) - "Avoid Ffuncall trampoline if possibile. -NARG is the number of Ffuncall arguments." - (comp-stack-adjust (- narg)) - (let* ((callee (comp-slot)) - (callee-sym-name (comp-mvar-constant callee)) - (optimize nil) - (callref nil)) - (and (comp-mvar-const-vld callee) - (or (and (>= comp-speed 2) - (eq callee-sym-name (comp-func-symbol-name comp-func)) - (setq optimize t) - (setq callref (comp-nargs-p (comp-func-args comp-func)))) - ;; (and (>= comp-speed 3) - ;; (symbol-function callee-sym-name) - ;; (subrp (symbol-function callee-sym-name)) - ;; (setq optimize t) - ;; (setq callref (eq 'many - ;; (cdr (subr-arity - ;; (symbol-function callee-sym-name))))) - ;; (setf callee-sym-name )) - )) - (if optimize - (if callref - (comp-emit-set-call (comp-callref callee-sym-name - narg (1+ (comp-sp)))) - (comp-emit-set-call `(call ,callee-sym-name - ,@(cl-loop for i from (1+ (comp-sp)) - repeat narg - collect (comp-slot-n i))))) - (comp-emit-set-call (comp-callref 'funcall (1+ narg) (comp-sp)))))) - (defmacro comp-op-case (&rest cases) "Expand CASES into the corresponding pcase. This is responsible for generating the proper stack adjustment when known and @@ -722,7 +690,8 @@ the annotation emission." (make-comp-mvar :constant arg) (comp-slot+1)))) (byte-call - (comp-emit-funcall arg)) + (comp-stack-adjust (- arg)) + (comp-emit-set-call (comp-callref 'funcall (1+ arg) (comp-sp)))) (byte-unbind (comp-emit (comp-call 'helper_unbind_n (make-comp-mvar :constant arg)))) commit a317620a52746ea4346eabf4559a1caac2b63011 Author: Andrea Corallo Date: Wed Sep 18 11:30:23 2019 +0200 add comp-call-optim pass diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 076380732f..8f93efd73a 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -56,6 +56,7 @@ comp-limplify comp-ssa comp-propagate + comp-call-optim comp-final) "Passes to be executed in order.") @@ -1320,6 +1321,31 @@ This can run just once." (comp-log-func comp-func))) funcs) + +;;; Call optimizer pass specific code. +;; Try to avoid funcall trampoline use when possible. + +(defun comp-call-optim (funcs) + (cl-loop + for comp-func in funcs + for self = (comp-func-symbol-name comp-func) + for self-callref = (comp-nargs-p (comp-func-args comp-func)) + when (and (>= comp-speed 2) + (not self-callref) ;; Could improve this + ) + do (cl-loop + for b being each hash-value of (comp-func-blocks comp-func) + do (cl-loop + for insn-cell on (comp-block-insns b) + for insn = (car insn-cell) + do (pcase insn + (`(set ,lval (callref funcall ,f . ,rest)) + (when (eq self (comp-mvar-constant f)) + (setcar insn-cell + `(set ,lval (call ,(comp-mvar-constant f) ,@rest)))))))) + (comp-log-func comp-func)) + funcs) + ;;; Final pass specific code. commit 47b22e55141da090a3d4688851eaa808f9489078 Author: Andrea Corallo Date: Tue Sep 17 13:18:40 2019 +0200 add pushhandler to clobber operators diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index c390225e06..076380732f 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -74,8 +74,9 @@ setimm set-par-to-local set-args-to-local - set-rest-args-to-local) - "Limple operators used to assign to mvars.") + set-rest-args-to-local + push-handler) + "Limple operators that clobbers the first mvar argument.") (defconst comp-mostly-pure-funcs '(% * + - / /= 1+ 1- < <= = > >= cons list % concat logand logcount logior commit 69cbf2b2f304f82c6d77cd663d4211bf125ebe74 Author: Andrea Corallo Date: Tue Sep 17 01:01:34 2019 +0200 keep on fixing ssa diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index f56a66a566..c390225e06 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -70,7 +70,11 @@ (% . number)) "Alist used for type propagation.") -(defconst comp-limple-assignments '(set setimm set-par-to-local) +(defconst comp-limple-assignments '(set + setimm + set-par-to-local + set-args-to-local + set-rest-args-to-local) "Limple operators used to assign to mvars.") (defconst comp-mostly-pure-funcs @@ -148,7 +152,10 @@ into it.") (df (make-hash-table) :type hash-table :documentation "Dominance frontier set. Block-name -> block") (post-num nil :type number - :documentation "Post order number.")) + :documentation "Post order number.") + (final-frame nil :type vector + :documentation "This is a copy of the frame when leaving the block. +Is in use to help the SSA rename pass.")) (cl-defstruct (comp-edge (:copier nil) (:constructor make--comp-edge)) "An edge connecting two basic blocks." @@ -894,7 +901,7 @@ the annotation emission." "Emit the prologue for a narg function." (cl-loop for i below minarg do (progn - (comp-emit `(set-args-to-local ,i)) + (comp-emit `(set-args-to-local ,(comp-slot-n i))) (comp-emit '(inc-args)))) (cl-loop for i from minarg below nonrest for bb = (intern (format "entry_%s" i)) @@ -903,7 +910,7 @@ the annotation emission." (comp-emit `(cond-jump-narg-leq ,i ,bb ,fallback)) (comp-mark-block-closed) (comp-emit-block bb) - (comp-emit `(set-args-to-local ,i)) + (comp-emit `(set-args-to-local ,(comp-slot-n i))) (comp-emit '(inc-args))) finally (comp-emit-jump 'entry_rest_args)) (cl-loop for i from minarg below nonrest @@ -911,7 +918,7 @@ the annotation emission." (comp-emit-block (intern (format "entry_fallback_%s" i))) (comp-emit-set-const nil))) (comp-emit-block 'entry_rest_args) - (comp-emit `(set-rest-args-to-local ,nonrest))) + (comp-emit `(set-rest-args-to-local ,(comp-slot-n nonrest)))) (defun comp-limplify-finalize-function (func) "Reverse insns into all basic blocks of FUNC." @@ -1130,14 +1137,14 @@ Top level forms for the current context are rendered too." (cl-loop for i from 0 below (comp-func-frame-size comp-func) ;; List of blocks with a definition of mvar i - with defs-v = (cl-loop with blocks = (comp-func-blocks comp-func) + for defs-v = (cl-loop with blocks = (comp-func-blocks comp-func) for b being each hash-value of blocks when (slot-assigned-p i b) collect b) ;; Set of basic blocks where phi is added. - with f = () + for f = () ;; Worklist, set of basic blocks that contain definitions of v. - with w = defs-v + for w = defs-v do (while w (let ((x (pop w))) @@ -1203,6 +1210,8 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non nil." (puthash bb t visited) (cl-loop for insn in (comp-block-insns bb) do (comp-ssa-rename-insn insn in-frame)) + (setf (comp-block-final-frame bb) + (copy-sequence in-frame)) (when-let ((out-edges (comp-block-out-edges bb))) (cl-loop for ed in out-edges for child = (comp-edge-dst ed) diff --git a/src/comp.c b/src/comp.c index 2846037e5a..8aadd5acc9 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1265,6 +1265,10 @@ emit_limple_insn (Lisp_Object insn) n); emit_cond_jump (test, target2, target1); } + else if (EQ (op, Qphi)) + { + /* Nothing to do for phis into the backend. */ + } else if (EQ (op, Qpush_handler)) { EMACS_UINT clobber_slot = XFIXNUM (FUNCALL1 (comp-mvar-slot, arg0)); @@ -1350,7 +1354,7 @@ emit_limple_insn (Lisp_Object insn) else if (EQ (op, Qset_args_to_local)) { /* - Limple: (set-args-to-local 1) + Limple: (set-args-to-local #s(comp-mvar 1 6 nil nil nil nil)) C: local[1] = *args; */ gcc_jit_rvalue *gcc_args = @@ -1360,7 +1364,7 @@ emit_limple_insn (Lisp_Object insn) gcc_jit_rvalue *res = gcc_jit_lvalue_as_rvalue (gcc_jit_rvalue_dereference (gcc_args, NULL)); - EMACS_UINT slot_n = XFIXNUM (arg0); + EMACS_UINT slot_n = XFIXNUM (FUNCALL1 (comp-mvar-slot, arg0)); gcc_jit_block_add_assignment (comp.block, NULL, comp.frame[slot_n], @@ -1369,13 +1373,15 @@ emit_limple_insn (Lisp_Object insn) else if (EQ (op, Qset_rest_args_to_local)) { /* - Limple: (set-rest-args-to-local 3) - C: local[3] = list (nargs - 3, args); + Limple: (set-rest-args-to-local #s(comp-mvar 2 9 nil nil nil nil)) + C: local[2] = list (nargs - 2, args); */ + + EMACS_UINT slot_n = XFIXNUM (FUNCALL1 (comp-mvar-slot, arg0)); gcc_jit_rvalue *n = gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.ptrdiff_type, - XFIXNUM (arg0)); + slot_n); gcc_jit_lvalue *nargs = gcc_jit_param_as_lvalue (gcc_jit_function_get_param (comp.func, 0)); gcc_jit_lvalue *args = @@ -1395,7 +1401,7 @@ emit_limple_insn (Lisp_Object insn) gcc_jit_block_add_assignment (comp.block, NULL, - comp.frame[XFIXNUM (arg0)], + comp.frame[slot_n], res); } else if (EQ (op, Qinc_args)) @@ -3274,6 +3280,7 @@ syms_of_comp (void) DEFSYM (Qreturn, "return"); DEFSYM (Qcomp_mvar, "comp-mvar"); DEFSYM (Qcond_jump, "cond-jump"); + DEFSYM (Qphi, "phi"); /* In use for prologue emission. */ DEFSYM (Qset_par_to_local, "set-par-to-local"); DEFSYM (Qset_args_to_local, "set-args-to-local"); commit 83a146b24ec230539c4520a4315b8bcdeebdb434 Author: Andrea Corallo Date: Mon Sep 16 22:18:58 2019 +0200 rewriting ssa rename diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index e15a29e779..f56a66a566 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -148,10 +148,7 @@ into it.") (df (make-hash-table) :type hash-table :documentation "Dominance frontier set. Block-name -> block") (post-num nil :type number - :documentation "Post order number.") - (final-frame nil :type vector - :documentation "This is a copy of the frame when leaving the block. -Is in use to help the SSA rename pass.")) + :documentation "Post order number.")) (cl-defstruct (comp-edge (:copier nil) (:constructor make--comp-edge)) "An edge connecting two basic blocks." @@ -227,12 +224,6 @@ LIMPLE basic block.") -(defsubst comp-mvar-propagate (lval rval) - "Propagate into LVAL properties of RVAL." - (setf (comp-mvar-const-vld lval) (comp-mvar-const-vld rval)) - (setf (comp-mvar-constant lval) (comp-mvar-constant rval)) - (setf (comp-mvar-type lval) (comp-mvar-type rval))) - (defun comp-assign-op-p (op) "Assignment predicate for OP." (cl-find op comp-limple-assignments)) @@ -1179,38 +1170,47 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non nil." (frame (comp-new-frame (comp-func-frame-size comp-func) t) :type vector :documentation "Vector of mvars.")) -(defun comp-ssa-rename-insn (insn slot-n) - (cl-flet ((target-p (x) - ;; Ret t if x is an mvar and target the correct slot number. - (and (comp-mvar-p x) - (eql slot-n (comp-mvar-slot x)))) - (new-lvalue () - ;; If is an assignment make a new mvar and put it as l-value. - (let ((mvar (make-comp-ssa-mvar :slot slot-n))) - (setf (aref (comp-ssa-frame comp-pass) slot-n) mvar) - (setf (cadr insn) mvar)))) - (pcase insn - (`(,(pred comp-assign-op-p) ,(pred target-p) . ,_) - (let ((mvar (aref (comp-ssa-frame comp-pass) slot-n))) - (cl-nsubst-if mvar #'target-p (cdr insn))) - (new-lvalue)) - (`(phi ,n) - (when (equal n slot-n) - (new-lvalue))) - (_ - (let ((mvar (aref (comp-ssa-frame comp-pass) slot-n))) - (cl-nsubst-if mvar #'target-p (cdr insn))))))) - -(defun comp-ssa-rename-in-blocks (n) - "Given slot number N rename in the blocks." - (comp-dom-tree-walker (gethash 'entry (comp-func-blocks comp-func)) - (lambda (b) - (cl-loop for insn in (comp-block-insns b) - do (comp-ssa-rename-insn insn n)) - ;; Save a copy into final frame while leaving. - (setf (aref (comp-block-final-frame b) n) - (aref (comp-ssa-frame comp-pass) n))) - nil)) +(defun comp-ssa-rename-insn (insn frame) + (dotimes (slot-n (comp-func-frame-size comp-func)) + (cl-flet ((target-p (x) + ;; Ret t if x is an mvar and target the correct slot number. + (and (comp-mvar-p x) + (eql slot-n (comp-mvar-slot x)))) + (new-lvalue () + ;; If is an assignment make a new mvar and put it as l-value. + (let ((mvar (make-comp-ssa-mvar :slot slot-n))) + (setf (aref frame slot-n) mvar) + (setf (cadr insn) mvar)))) + (pcase insn + (`(,(pred comp-assign-op-p) ,(pred target-p) . ,_) + (let ((mvar (aref frame slot-n))) + (setcdr insn (cl-nsubst-if mvar #'target-p (cdr insn)))) + (new-lvalue)) + (`(phi ,n) + (when (equal n slot-n) + (new-lvalue))) + (_ + (let ((mvar (aref frame slot-n))) + (setcdr insn (cl-nsubst-if mvar #'target-p (cdr insn))))))))) + +(defun comp-ssa-rename () + "Entry point to rename SSA within the current function." + (comp-log "Renaming\n") + (let ((frame-size (comp-func-frame-size comp-func)) + (visited (make-hash-table))) + (cl-labels ((ssa-rename-rec (bb in-frame) + (unless (gethash bb visited) + (puthash bb t visited) + (cl-loop for insn in (comp-block-insns bb) + do (comp-ssa-rename-insn insn in-frame)) + (when-let ((out-edges (comp-block-out-edges bb))) + (cl-loop for ed in out-edges + for child = (comp-edge-dst ed) + ;; Provide a copy of the same frame to all childs. + do (ssa-rename-rec child (copy-sequence in-frame))))))) + + (ssa-rename-rec (gethash 'entry (comp-func-blocks comp-func)) + (comp-new-frame frame-size t))))) (defun comp-finalize-phis () "Fixup r-values into phis in all basic blocks." @@ -1228,19 +1228,6 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non nil." when (eq op 'phi) do (finalize-phi args b))))) -(defun comp-ssa-rename () - "Entry point to rename SSA within the current function." - (comp-log "Renaming\n") - (let ((frame-size (comp-func-frame-size comp-func))) - ;; Initialize the final frame. - (cl-loop for b being each hash-value of (comp-func-blocks comp-func) - do (setf (comp-block-final-frame b) (make-vector frame-size nil))) - ;; Do the renaming for each frame slot. - (cl-loop with comp-pass = (make-comp-ssa) - for n from 0 below frame-size - ;; For every slot frame rename down to the dominator tree. - do (comp-ssa-rename-in-blocks n)))) - (defun comp-ssa (funcs) "Port FUNCS into mininal SSA form." (cl-loop for comp-func in funcs @@ -1273,6 +1260,12 @@ This can run just once." (setf (comp-mvar-constant lval) v) (setf (comp-mvar-type lval) (type-of v))))))) +(defsubst comp-mvar-propagate (lval rval) + "Propagate into LVAL properties of RVAL." + (setf (comp-mvar-const-vld lval) (comp-mvar-const-vld rval)) + (setf (comp-mvar-constant lval) (comp-mvar-constant rval)) + (setf (comp-mvar-type lval) (comp-mvar-type rval))) + (defun comp-propagate-insn (insn) (pcase insn (`(set ,lval ,rval) commit 17ecb1c728edebd00a787fd6c4bdf8b7722e9a2f Author: Andrea Corallo Date: Mon Sep 16 22:18:19 2019 +0200 give back basic block a C like name diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index c7d9ab3795..e15a29e779 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -590,7 +590,7 @@ If NEGATED non nil negate the tested condition." (defun comp-new-block-sym () "Return a symbol naming the next new basic block." - (intern (format "bb-%s" (hash-table-count (comp-func-blocks comp-func))))) + (intern (format "bb_%s" (hash-table-count (comp-func-blocks comp-func))))) (defun comp-lap-to-limple-bb (n) "Given the LAP label N return the limple basic block." @@ -971,7 +971,7 @@ This will be called at runtime." (comp-emit-narg-prologue args-min nonrest) (cl-incf (comp-sp) (1+ nonrest)))) ;; Body - (comp-emit-block 'bb-1) + (comp-emit-block 'bb_1) (mapc #'comp-limplify-lap-inst (comp-func-lap func)) (comp-limplify-finalize-function func))) @@ -1071,7 +1071,7 @@ Top level forms for the current context are rendered too." (when-let ((blocks (comp-func-blocks comp-func)) (entry (gethash 'entry blocks)) ;; No point to go on if the only bb is 'entry'. - (bb1 (gethash 'bb-1 blocks))) + (bb1 (gethash 'bb_1 blocks))) (cl-loop with rev-bb-list = (comp-collect-rev-post-order entry) with changed = t while changed commit aba160b043588171eac8235105d45b30a7f141f5 Author: Andrea Corallo Date: Mon Sep 16 20:23:57 2019 +0200 fix callref parsing into C back-end diff --git a/src/comp.c b/src/comp.c index f2733625b5..2846037e5a 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1147,8 +1147,8 @@ emit_limple_call_ref (Lisp_Object insn) #s(comp-mvar 2 11 t 10 integer t)). */ Lisp_Object callee = FIRST (insn); - EMACS_UINT nargs = XFIXNUM (Flength (CDR (CDR (insn)))); - EMACS_UINT base_ptr = XFIXNUM (FUNCALL1 (comp-mvar-slot, THIRD (insn))); + EMACS_UINT nargs = XFIXNUM (Flength (CDR (insn))); + EMACS_UINT base_ptr = XFIXNUM (FUNCALL1 (comp-mvar-slot, SECOND (insn))); return emit_call_ref (callee, nargs, comp.frame[base_ptr]); } commit 05b733e86c108bdacd3ff45d05d560d7b8778a9b Author: Andrea Corallo Date: Mon Sep 16 20:11:05 2019 +0200 fix comp-compute-edges handling all kind of branches diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 04096d65a9..c7d9ab3795 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1008,16 +1008,19 @@ Top level forms for the current context are rendered too." (cl-loop with blocks = (comp-func-blocks comp-func) for bb being each hash-value of blocks for last-insn = (car (last (comp-block-insns bb))) - for (op first _ third forth) = last-insn + for (op first second third forth) = last-insn do (cl-ecase op (jump - (edge-add :src bb :dst (gethash first - blocks))) + (edge-add :src bb :dst (gethash first blocks))) (cond-jump - (edge-add :src bb :dst (gethash third - blocks)) - (edge-add :src bb :dst (gethash forth - blocks))) + (edge-add :src bb :dst (gethash third blocks)) + (edge-add :src bb :dst (gethash forth blocks))) + (cond-jump-narg-leq + (edge-add :src bb :dst (gethash second blocks)) + (edge-add :src bb :dst (gethash third blocks))) + (push-handler + (edge-add :src bb :dst (gethash third blocks)) + (edge-add :src bb :dst (gethash forth blocks))) (return)) finally (progn (setf (comp-func-edges comp-func) commit ca28d5fd72d3cc7e960f4f2bd1d8cf00ac3622dd Author: Andrea Corallo Date: Mon Sep 16 19:48:13 2019 +0200 add some notes diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index da2c488ef7..04096d65a9 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -222,7 +222,7 @@ LIMPLE basic block.") (defvar comp-ctxt) ;; FIXME (to be removed) ;; Special vars used by some passes -(defvar comp-block) +(defvar comp-block) ; Can probably be removed (defvar comp-func) @@ -884,7 +884,7 @@ the annotation emission." (comp-stack-adjust (- 1 arg)) (comp-emit-set-call (comp-callref 'insert arg (comp-sp)))) (byte-stack-set - (comp-with-sp (1+ (comp-sp)) + (comp-with-sp (1+ (comp-sp)) ;; FIXME!! (comp-copy-slot (comp-sp) (- (comp-sp) arg)))) (byte-stack-set2 (cl-assert nil)) ;; TODO (byte-discardN commit 6d1c453726cf8a903c6bc555bacf20b7a4ac8651 Author: Andrea Corallo Date: Mon Sep 16 19:47:49 2019 +0200 fix switch emission due to missing const prop diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 615d34268a..da2c488ef7 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -615,13 +615,15 @@ If NEGATED non nil negate the tested condition." (comp-mark-block-closed) (comp-emit-block guarded-bb)))) -(defun comp-emit-switch (var m-hash) - "Emit a limple for a lap jump table given VAR and M-HASH." - (cl-assert (comp-mvar-const-vld m-hash)) - (cl-loop for test being each hash-keys of (comp-mvar-constant m-hash) - using (hash-value target-label) - for m-test = (make-comp-mvar :constant test) - do (comp-emit-cond-jump var m-test 0 target-label nil))) +(defun comp-emit-switch (var last-insn) + "Emit a limple for a lap jump table given VAR and LAST-INSN." + (pcase last-insn + (`(setimm ,_ ,_ ,const) + (cl-loop for test being each hash-keys of const + using (hash-value target-label) + for m-test = (make-comp-mvar :constant test) + do (comp-emit-cond-jump var m-test 0 target-label nil))) + (_ (error "Missing previous setimm while creating a switch")))) (defun comp-emit-funcall (narg) "Avoid Ffuncall trampoline if possibile. @@ -888,7 +890,9 @@ the annotation emission." (byte-discardN (comp-stack-adjust (- arg))) (byte-switch - (comp-emit-switch (comp-slot+1) (comp-slot-n (+ 2 (comp-sp))))) + ;; Assume to follow the emission of a setimm. + ;; This is checked into comp-emit-switch. + (comp-emit-switch (comp-slot+1) (cl-second (comp-block-insns comp-block)))) (byte-constant (comp-emit-set-const arg)) (byte-discardN-preserve-tos commit 747c6a0dc8e53d66c785500d122957f4a17a9325 Author: Andrea Corallo Date: Sun Sep 15 15:41:42 2019 +0200 modify callref format to explicitate mvars diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 21a80c0472..615d34268a 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -425,7 +425,10 @@ If INPUT is a string this is the file path to be compiled." (defun comp-callref (func &rest args) "Emit a call usign narg abi for FUNC with ARGS." (comp-add-subr-to-relocs func) - `(callref ,func ,@args)) + `(callref ,func ,@(cl-loop with (nargs off) = args + repeat nargs + for sp from off + collect (comp-slot-n sp)))) (cl-defun make-comp-mvar (&key slot (constant nil const-vld) type) (when const-vld diff --git a/src/comp.c b/src/comp.c index 1c201c16c9..f2733625b5 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1143,11 +1143,12 @@ emit_limple_call (Lisp_Object insn) static gcc_jit_rvalue * emit_limple_call_ref (Lisp_Object insn) { - /* Ex: (callref Fplus 2 0). */ + /* Ex: (callref < #s(comp-mvar 1 6 nil nil nil t) + #s(comp-mvar 2 11 t 10 integer t)). */ Lisp_Object callee = FIRST (insn); - EMACS_UINT nargs = XFIXNUM (SECOND (insn)); - EMACS_UINT base_ptr = XFIXNUM (THIRD (insn)); + EMACS_UINT nargs = XFIXNUM (Flength (CDR (CDR (insn)))); + EMACS_UINT base_ptr = XFIXNUM (FUNCALL1 (comp-mvar-slot, THIRD (insn))); return emit_call_ref (callee, nargs, comp.frame[base_ptr]); } commit 351576f913ded76fc2e984c3ad42d47c5c5bc482 Author: Andrea Corallo Date: Sun Sep 15 14:43:30 2019 +0200 adding propagation diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 963e7e03c4..21a80c0472 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -55,10 +55,19 @@ (defconst comp-passes '(comp-spill-lap comp-limplify comp-ssa + comp-propagate comp-final) "Passes to be executed in order.") -(defconst comp-known-ret-types '((cons . cons)) +;; TODO hash here. +(defconst comp-known-ret-types '((cons . cons) + (1+ . number) + (1- . number) + (+ . number) + (- . number) + (* . number) + (/ . number) + (% . number)) "Alist used for type propagation.") (defconst comp-limple-assignments '(set setimm set-par-to-local) @@ -200,13 +209,15 @@ LIMPLE basic block.") :documentation "Slot number.") (id nil :type (or null number) :documentation "SSA number.") - (const-vld nil + (const-vld nil :type boolean :documentation "Valid signal for the following slot.") (constant nil :documentation "When const-vld non nil this is used for constant propagation.") (type nil - :documentation "When non nil is used for type propagation.")) + :documentation "When non nil is used for type propagation.") + (ref nil :type boolean + :documentation "When t this is used by reference.")) (defvar comp-ctxt) ;; FIXME (to be removed) @@ -215,6 +226,13 @@ LIMPLE basic block.") (defvar comp-func) + +(defsubst comp-mvar-propagate (lval rval) + "Propagate into LVAL properties of RVAL." + (setf (comp-mvar-const-vld lval) (comp-mvar-const-vld rval)) + (setf (comp-mvar-constant lval) (comp-mvar-constant rval)) + (setf (comp-mvar-type lval) (comp-mvar-type rval))) + (defun comp-assign-op-p (op) "Assignment predicate for OP." (cl-find op comp-limple-assignments)) @@ -1230,6 +1248,64 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non nil." (comp-log-func comp-func))) funcs) + +;;; propagate pass specific code. +;; A very basic propagation pass follows. + +(defun comp-basic-const-propagate () + "Propagate simple constants for setimm operands. +This can run just once." + (cl-loop for b being each hash-value of (comp-func-blocks comp-func) + do (cl-loop for insn in (comp-block-insns b) + do (pcase insn + (`(setimm ,lval ,_ ,v) + (setf (comp-mvar-const-vld lval) t) + (setf (comp-mvar-constant lval) v) + (setf (comp-mvar-type lval) (type-of v))))))) + +(defun comp-propagate-insn (insn) + (pcase insn + (`(set ,lval ,rval) + (pcase rval + (`(call ,f . ,_) + (setf (comp-mvar-type lval) + (cdr (assq f comp-known-ret-types)))) + (`(callref ,f . ,args) + (cl-loop for v in args + do (setf (comp-mvar-ref v) t)) + (setf (comp-mvar-type lval) + (cdr (assq f comp-known-ret-types)))) + (_ + (comp-mvar-propagate lval rval)))) + (`(phi ,lval . ,rest) + ;; Const prop here. + (when (and (cl-every #'comp-mvar-const-vld rest) + (cl-reduce #'equal (mapcar #'comp-mvar-constant rest))) + (setf (comp-mvar-constant lval) (comp-mvar-constant (car rest)))) + ;; Type propagation. + ;; FIXME: checking for type equality is not sufficient cause does not + ;; account type hierarchy!! + (when (cl-reduce #'eq (mapcar #'comp-mvar-type rest)) + (setf (comp-mvar-type lval) (comp-mvar-type (car rest)))) + ;; Reference propagation. + (setf (comp-mvar-ref lval) (cl-every #'comp-mvar-ref rest))))) + +(defun comp-propagate* () + "Propagate for set and phi operands." + (cl-loop for b being each hash-value of (comp-func-blocks comp-func) + do (cl-loop for insn in (comp-block-insns b) + do (comp-propagate-insn insn)))) + +(defun comp-propagate (funcs) + (cl-loop for comp-func in funcs + do + (progn + (comp-basic-const-propagate) + ;; FIXME: unbelievably dumb... + (cl-loop repeat 10 + do (comp-propagate*)) + (comp-log-func comp-func))) + funcs) ;;; Final pass specific code. commit 94cae7b2bc02f49f238496ae4c386bcb9cafaeea Author: Andrea Corallo Date: Sun Sep 15 12:31:44 2019 +0200 fix again ssa renaming diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 51a120bb40..963e7e03c4 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1163,7 +1163,9 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non nil." (setf (cadr insn) mvar)))) (pcase insn (`(,(pred comp-assign-op-p) ,(pred target-p) . ,_) - (cl-nsubst-if (new-lvalue) #'target-p (cddr insn))) + (let ((mvar (aref (comp-ssa-frame comp-pass) slot-n))) + (cl-nsubst-if mvar #'target-p (cdr insn))) + (new-lvalue)) (`(phi ,n) (when (equal n slot-n) (new-lvalue))) @@ -1177,9 +1179,9 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non nil." (lambda (b) (cl-loop for insn in (comp-block-insns b) do (comp-ssa-rename-insn insn n)) - ;; Save a copy of the frame while leaving. - (setf (comp-block-final-frame b) - (copy-sequence (comp-ssa-frame comp-pass)))) + ;; Save a copy into final frame while leaving. + (setf (aref (comp-block-final-frame b) n) + (aref (comp-ssa-frame comp-pass) n))) nil)) (defun comp-finalize-phis () @@ -1201,10 +1203,15 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non nil." (defun comp-ssa-rename () "Entry point to rename SSA within the current function." (comp-log "Renaming\n") - (cl-loop with comp-pass = (make-comp-ssa) - for n from 0 below (comp-func-frame-size comp-func) - ;; For every slot frame rename down to the dominator tree. - do (comp-ssa-rename-in-blocks n))) + (let ((frame-size (comp-func-frame-size comp-func))) + ;; Initialize the final frame. + (cl-loop for b being each hash-value of (comp-func-blocks comp-func) + do (setf (comp-block-final-frame b) (make-vector frame-size nil))) + ;; Do the renaming for each frame slot. + (cl-loop with comp-pass = (make-comp-ssa) + for n from 0 below frame-size + ;; For every slot frame rename down to the dominator tree. + do (comp-ssa-rename-in-blocks n)))) (defun comp-ssa (funcs) "Port FUNCS into mininal SSA form." @@ -1220,7 +1227,9 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non nil." (comp-place-phis) (comp-ssa-rename) (comp-finalize-phis) - (comp-log-func comp-func)))) + (comp-log-func comp-func))) + funcs) + ;;; Final pass specific code. @@ -1234,8 +1243,7 @@ Prepare every functions for final compilation and drive the C side." (cl-loop with h = (comp-ctxt-funcs-h comp-ctxt) for f being each hash-value of h for args = (comp-func-args f) - for doc = (when (> (length (comp-func-byte-func f)) - 4) + for doc = (when (> (length (comp-func-byte-func f)) 4) (aref (comp-func-byte-func f) 4)) collect (vector (comp-func-symbol-name f) (comp-func-c-func-name f) commit bbde29c012868e130388d9975beded563643a7a7 Author: Andrea Corallo Date: Sun Sep 15 12:08:22 2019 +0200 add ssa param to comp-new-frame diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 11da06cc02..51a120bb40 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -415,11 +415,13 @@ If INPUT is a string this is the file path to be compiled." (make--comp-mvar :slot slot :const-vld const-vld :constant constant :type type)) -(defun comp-new-frame (size) +(defun comp-new-frame (size &optional ssa) "Return a clean frame of meta variables of size SIZE." (cl-loop with v = (make-vector size nil) for i below size - do (aset v i (make-comp-mvar :slot i)) + for mvar = (if ssa (make-comp-ssa-mvar :slot i) + (make-comp-mvar :slot i)) + do (aset v i mvar) finally (return v))) (defmacro comp-sp () commit 33ce5fe9da02f0d0f4e0c32b86dde5c5e81c9565 Author: Andrea Corallo Date: Sun Sep 15 12:07:04 2019 +0200 clean-up limplify diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 0ad8b1a310..11da06cc02 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -491,10 +491,6 @@ If DST-N is specified use it otherwise assume it to be the current slot." (comp-with-sp (if dst-n dst-n (comp-sp)) (let ((src-slot (comp-slot-n src-n))) (cl-assert src-slot) - ;; FIXME id should encrease here. - (setf (comp-slot) - (copy-sequence src-slot)) - (setf (comp-mvar-slot (comp-slot)) (comp-sp)) (comp-emit `(set ,(comp-slot) ,src-slot))))) (defun comp-emit-annotation (str) @@ -533,10 +529,6 @@ If DST-N is specified use it otherwise assume it to be the current slot." (comp-emit-jump block-name)) ;; Set this a currently compiled block. (setf comp-block (gethash block-name blocks)) - ;; Every new block we are forced to wipe out all the frame. - ;; This will be optimized by proper flow analysis. - (setf (comp-limplify-frame comp-pass) - (comp-new-frame (comp-func-frame-size comp-func))) ;; If we are landing here form a recorded branch adjust sp accordingly. (setf (comp-sp) (comp-block-sp (gethash block-name blocks))) @@ -1154,7 +1146,7 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non nil." (cl-defstruct (comp-ssa (:copier nil)) "Support structure used while SSA renaming." - (frame (comp-new-frame (comp-func-frame-size comp-func)) :type vector + (frame (comp-new-frame (comp-func-frame-size comp-func) t) :type vector :documentation "Vector of mvars.")) (defun comp-ssa-rename-insn (insn slot-n) commit c74f30c8e0f1799ebca7eb144c56506a53290243 Author: Andrea Corallo Date: Sun Sep 15 10:50:33 2019 +0200 fix ssa renaming diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 08a6d59ff9..0ad8b1a310 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1169,13 +1169,13 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non nil." (setf (cadr insn) mvar)))) (pcase insn (`(,(pred comp-assign-op-p) ,(pred target-p) . ,_) - (new-lvalue)) - (`(phi . ,_) - (new-lvalue)) + (cl-nsubst-if (new-lvalue) #'target-p (cddr insn))) + (`(phi ,n) + (when (equal n slot-n) + (new-lvalue))) (_ (let ((mvar (aref (comp-ssa-frame comp-pass) slot-n))) - ;; Should we have to recur for nested args? - (cl-nsubstitute-if mvar #'target-p (cdr insn))))))) + (cl-nsubst-if mvar #'target-p (cdr insn))))))) (defun comp-ssa-rename-in-blocks (n) "Given slot number N rename in the blocks." commit d7173579a7e9a0f71ccd02fdc9f694b49aadbd47 Author: Andrea Corallo Date: Sat Sep 14 18:12:16 2019 +0200 remove incomplete propagation during limplification pass diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 7804f97bf6..08a6d59ff9 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -197,8 +197,8 @@ LIMPLE basic block.") (cl-defstruct (comp-mvar (:copier nil) (:constructor make--comp-mvar)) "A meta-variable being a slot in the meta-stack." (slot nil :type fixnum - :documentation "Slot position.") - (id nil :type number + :documentation "Slot number.") + (id nil :type (or null number) :documentation "SSA number.") (const-vld nil :documentation "Valid signal for the following slot.") @@ -409,6 +409,12 @@ If INPUT is a string this is the file path to be compiled." (comp-add-subr-to-relocs func) `(callref ,func ,@args)) +(cl-defun make-comp-mvar (&key slot (constant nil const-vld) type) + (when const-vld + (comp-add-const-to-relocs constant)) + (make--comp-mvar :slot slot :const-vld const-vld :constant constant + :type type)) + (defun comp-new-frame (size) "Return a clean frame of meta variables of size SIZE." (cl-loop with v = (make-vector size nil) @@ -416,13 +422,6 @@ If INPUT is a string this is the file path to be compiled." do (aset v i (make-comp-mvar :slot i)) finally (return v))) -(cl-defun make-comp-mvar (&key slot (constant nil const-vld) type) - (when const-vld - (comp-add-const-to-relocs constant)) - (make--comp-mvar :id (funcall (comp-func-ssa-cnt-gen comp-func)) - :slot slot :const-vld const-vld :constant constant - :type type)) - (defmacro comp-sp () "Current stack pointer." '(comp-limplify-sp comp-pass)) @@ -459,11 +458,6 @@ Restore the original value afterwards." "Emit CALL assigning the result the the current slot frame. If the callee function is known to have a return type propagate it." (cl-assert call) - (setf (comp-slot) - (make-comp-mvar :slot (comp-sp) - :type (when (> comp-speed 0) - (alist-get (cadr call) - comp-known-ret-types)))) (comp-emit (list 'set (comp-slot) call))) (defmacro comp-emit-set-call-subr (subr-name sp-delta) @@ -511,8 +505,6 @@ If DST-N is specified use it otherwise assume it to be the current slot." "Set constant VAL to current slot." (let ((rel-idx (comp-add-const-to-relocs val))) (cl-assert (numberp rel-idx)) - (setf (comp-slot) (make-comp-mvar :slot (comp-sp) - :constant val)) (comp-emit `(setimm ,(comp-slot) ,rel-idx ,val)))) (defun comp-mark-block-closed () @@ -976,10 +968,15 @@ Top level forms for the current context are rendered too." ;; implicit phi is present for every slot at the beginning of every basic block. ;; This pass is responsible for building all the edges and replace all m-vars ;; plus placing the needed phis. -;; Becase the number of phis placed is (supposed) to be the minimum necessary +;; Because the number of phis placed is (supposed) to be the minimum necessary ;; this form is called 'minimal SSA form'. ;; This pass should be run every time basic blocks or mvar are shuffled. +(cl-defun make-comp-ssa-mvar (&key slot (constant nil const-vld) type) + (make--comp-mvar :id (funcall (comp-func-ssa-cnt-gen comp-func)) + :slot slot :const-vld const-vld :constant constant + :type type)) + (defun comp-compute-edges () "Compute the basic block edges for the current function." (cl-flet ((edge-add (&rest args) @@ -1167,7 +1164,7 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non nil." (eql slot-n (comp-mvar-slot x)))) (new-lvalue () ;; If is an assignment make a new mvar and put it as l-value. - (let ((mvar (make-comp-mvar :slot slot-n))) + (let ((mvar (make-comp-ssa-mvar :slot slot-n))) (setf (aref (comp-ssa-frame comp-pass) slot-n) mvar) (setf (cadr insn) mvar)))) (pcase insn commit 7abf1ca1212d91d0d50d3dd4f6386fac98fd2209 Author: Andrea Corallo Date: Sat Sep 14 17:55:03 2019 +0200 add phi finalizer diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index ab2d77d76c..7804f97bf6 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -139,7 +139,10 @@ into it.") (df (make-hash-table) :type hash-table :documentation "Dominance frontier set. Block-name -> block") (post-num nil :type number - :documentation "Post order number.")) + :documentation "Post order number.") + (final-frame nil :type vector + :documentation "This is a copy of the frame when leaving the block. +Is in use to help the SSA rename pass.")) (cl-defstruct (comp-edge (:copier nil) (:constructor make--comp-edge)) "An edge connecting two basic blocks." @@ -1138,7 +1141,7 @@ Top level forms for the current context are rendered too." (unless (cl-find y defs-v) (push y w))))))))) -(defun comp-dominator-tree-walker (bb pre-lambda post-lambda) +(defun comp-dom-tree-walker (bb pre-lambda post-lambda) "Dominator tree walker function starting from basic block BB. PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non nil." (when pre-lambda @@ -1148,7 +1151,7 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non nil." for child = (comp-edge-dst ed) when (eq bb (comp-block-dom child)) ;; Current block is the immediate dominator then recur. - do (comp-dominator-tree-walker child pre-lambda post-lambda))) + do (comp-dom-tree-walker child pre-lambda post-lambda))) (when post-lambda (funcall post-lambda bb))) @@ -1161,25 +1164,48 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non nil." (cl-flet ((target-p (x) ;; Ret t if x is an mvar and target the correct slot number. (and (comp-mvar-p x) - (eql slot-n (comp-mvar-slot x))))) + (eql slot-n (comp-mvar-slot x)))) + (new-lvalue () + ;; If is an assignment make a new mvar and put it as l-value. + (let ((mvar (make-comp-mvar :slot slot-n))) + (setf (aref (comp-ssa-frame comp-pass) slot-n) mvar) + (setf (cadr insn) mvar)))) (pcase insn (`(,(pred comp-assign-op-p) ,(pred target-p) . ,_) - ;; If is an assignment make a new mvar and put it as l-value. - (let ((mvar (make-comp-mvar :slot slot-n))) - (setf (aref (comp-ssa-frame comp-pass) slot-n) mvar) - (setf (cadr insn) mvar))) + (new-lvalue)) + (`(phi . ,_) + (new-lvalue)) (_ (let ((mvar (aref (comp-ssa-frame comp-pass) slot-n))) - ;; Should we have to recur? + ;; Should we have to recur for nested args? (cl-nsubstitute-if mvar #'target-p (cdr insn))))))) (defun comp-ssa-rename-in-blocks (n) "Given slot number N rename in the blocks." - (comp-dominator-tree-walker (gethash 'entry (comp-func-blocks comp-func)) - (lambda (b) - (cl-loop for insn in (comp-block-insns b) - do (comp-ssa-rename-insn insn n))) - nil)) + (comp-dom-tree-walker (gethash 'entry (comp-func-blocks comp-func)) + (lambda (b) + (cl-loop for insn in (comp-block-insns b) + do (comp-ssa-rename-insn insn n)) + ;; Save a copy of the frame while leaving. + (setf (comp-block-final-frame b) + (copy-sequence (comp-ssa-frame comp-pass)))) + nil)) + +(defun comp-finalize-phis () + "Fixup r-values into phis in all basic blocks." + (cl-flet ((finalize-phi (args b) + ;; Concatenate into args all incoming mvars for this phi. + (setcdr args + (cl-loop with slot-n = (comp-mvar-slot (car args)) + for e in (comp-block-in-edges b) + for b = (comp-edge-src e) + for in-frame = (comp-block-final-frame b) + collect (aref in-frame slot-n))) )) + + (cl-loop for b being each hash-value of (comp-func-blocks comp-func) + do (cl-loop for (op . args) in (comp-block-insns b) + when (eq op 'phi) + do (finalize-phi args b))))) (defun comp-ssa-rename () "Entry point to rename SSA within the current function." @@ -1202,6 +1228,7 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non nil." (comp-log-block-info) (comp-place-phis) (comp-ssa-rename) + (comp-finalize-phis) (comp-log-func comp-func)))) commit b7d1b2e9462e8d81ec44c41d82d1b840ebc831f0 Author: Andrea Corallo Date: Sat Sep 14 17:00:16 2019 +0200 add ssa renaming diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 47b034d093..ab2d77d76c 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -193,10 +193,10 @@ LIMPLE basic block.") (cl-defstruct (comp-mvar (:copier nil) (:constructor make--comp-mvar)) "A meta-variable being a slot in the meta-stack." - (id nil :type number - :documentation "SSA number.") (slot nil :type fixnum :documentation "Slot position.") + (id nil :type number + :documentation "SSA number.") (const-vld nil :documentation "Valid signal for the following slot.") (constant nil @@ -212,6 +212,10 @@ LIMPLE basic block.") (defvar comp-func) +(defun comp-assign-op-p (op) + "Assignment predicate for OP." + (cl-find op comp-limple-assignments)) + (defun comp-add-const-to-relocs (obj) "Keep track of OBJ into the ctxt relocations. The corresponding index is returned." @@ -1107,8 +1111,7 @@ Top level forms for the current context are rendered too." (slot-assigned-p (slot-n bb) ;; Return t if a SLOT-N was assigned within BB. (cl-loop for insn in (comp-block-insns bb) - for op = (car insn) - when (and (cl-find op comp-limple-assignments) + when (and (comp-assign-op-p (car insn)) (= slot-n (comp-mvar-slot (cadr insn)))) do (return t)))) @@ -1131,7 +1134,7 @@ Top level forms for the current context are rendered too." (add-phi i y) (push y f) ;; Adding a phi implies mentioning the - ;; correspondig slot so in case adjust w. + ;; corresponding slot so in case adjust w. (unless (cl-find y defs-v) (push y w))))))))) @@ -1144,17 +1147,47 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non nil." (cl-loop for ed in out-edges for child = (comp-edge-dst ed) when (eq bb (comp-block-dom child)) - ;; Current block is the immediate dominator the recur. + ;; Current block is the immediate dominator then recur. do (comp-dominator-tree-walker child pre-lambda post-lambda))) (when post-lambda (funcall post-lambda bb))) -(defun comp-rename-mvars () - "Rename all mvar accoring to the new SSA rapresentation." - ;; Originally based on: Static Single Assignment Book - ;; Algorithm 3.3: Renaming algorithm - (comp-dominator-tree-walker (gethash 'entry (comp-func-blocks comp-func)) nil - (lambda (bb) (comp-log (format "\n%s" (comp-block-name bb)))))) +(cl-defstruct (comp-ssa (:copier nil)) + "Support structure used while SSA renaming." + (frame (comp-new-frame (comp-func-frame-size comp-func)) :type vector + :documentation "Vector of mvars.")) + +(defun comp-ssa-rename-insn (insn slot-n) + (cl-flet ((target-p (x) + ;; Ret t if x is an mvar and target the correct slot number. + (and (comp-mvar-p x) + (eql slot-n (comp-mvar-slot x))))) + (pcase insn + (`(,(pred comp-assign-op-p) ,(pred target-p) . ,_) + ;; If is an assignment make a new mvar and put it as l-value. + (let ((mvar (make-comp-mvar :slot slot-n))) + (setf (aref (comp-ssa-frame comp-pass) slot-n) mvar) + (setf (cadr insn) mvar))) + (_ + (let ((mvar (aref (comp-ssa-frame comp-pass) slot-n))) + ;; Should we have to recur? + (cl-nsubstitute-if mvar #'target-p (cdr insn))))))) + +(defun comp-ssa-rename-in-blocks (n) + "Given slot number N rename in the blocks." + (comp-dominator-tree-walker (gethash 'entry (comp-func-blocks comp-func)) + (lambda (b) + (cl-loop for insn in (comp-block-insns b) + do (comp-ssa-rename-insn insn n))) + nil)) + +(defun comp-ssa-rename () + "Entry point to rename SSA within the current function." + (comp-log "Renaming\n") + (cl-loop with comp-pass = (make-comp-ssa) + for n from 0 below (comp-func-frame-size comp-func) + ;; For every slot frame rename down to the dominator tree. + do (comp-ssa-rename-in-blocks n))) (defun comp-ssa (funcs) "Port FUNCS into mininal SSA form." @@ -1168,8 +1201,8 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non nil." (comp-compute-dominator-frontiers) (comp-log-block-info) (comp-place-phis) - (comp-log-func comp-func) - (comp-rename-mvars)))) + (comp-ssa-rename) + (comp-log-func comp-func)))) ;;; Final pass specific code. commit cb2e6461f3db45df70334016b2a8411605eb847f Author: Andrea Corallo Date: Sat Sep 14 15:25:11 2019 +0200 core reorder diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 2679ea390a..47b034d093 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -205,17 +205,12 @@ LIMPLE basic block.") (type nil :documentation "When non nil is used for type propagation.")) -(cl-defstruct (comp-limplify (:copier nil)) - "Support structure used during function limplification." - (sp 0 :type fixnum - :documentation "Current stack pointer while walking LAP.") - (frame nil :type vector - :documentation "Meta-stack used to flat LAP.") - (block-name nil :type symbol - :documentation "Current basic block name.")) - (defvar comp-ctxt) ;; FIXME (to be removed) +;; Special vars used by some passes +(defvar comp-block) +(defvar comp-func) + (defun comp-add-const-to-relocs (obj) "Keep track of OBJ into the ctxt relocations. @@ -376,9 +371,14 @@ If INPUT is a string this is the file path to be compiled." ;;; Limplification pass specific code. -;; Special vars used during limplifications -(defvar comp-block) -(defvar comp-func) +(cl-defstruct (comp-limplify (:copier nil)) + "Support structure used during function limplification." + (sp 0 :type fixnum + :documentation "Current stack pointer while walking LAP.") + (frame nil :type vector + :documentation "Meta-stack used to flat LAP.") + (block-name nil :type symbol + :documentation "Current basic block name.")) (cl-defun comp-block-maybe-add (&rest args &key name &allow-other-keys) (let ((blocks (comp-func-blocks comp-func))) commit 6963deed24b13b448835be0d72d9b943ae2a345f Author: Andrea Corallo Date: Sat Sep 14 14:51:43 2019 +0200 add comp-dominator-tree-walker diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 30381e5fd4..2679ea390a 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1024,8 +1024,8 @@ Top level forms for the current context are rendered too." (defun comp-compute-dominator-tree () "Compute immediate dominators for each basic block in current function." + ;; Originally based on: "A Simple, Fast Dominance Algorithm" ;; Cooper, Keith D.; Harvey, Timothy J.; Kennedy, Ken (2001). - ;; "A Simple, Fast Dominance Algorithm". (cl-flet ((intersect (b1 b2) (let ((finger1 (comp-block-post-num b1)) (finger2 (comp-block-post-num b2))) @@ -1072,7 +1072,7 @@ Top level forms for the current context are rendered too." (setf changed t))))))) (defun comp-compute-dominator-frontiers () - ;; Again from : "A Simple, Fast Dominance Algorithm" + ;; Originally based on: "A Simple, Fast Dominance Algorithm" ;; Cooper, Keith D.; Harvey, Timothy J.; Kennedy, Ken (2001). (cl-loop with blocks = (comp-func-blocks comp-func) for b-name being each hash-keys of blocks @@ -1099,7 +1099,7 @@ Top level forms for the current context are rendered too." (defun comp-place-phis () "Place phi insns into the current function." - ;; Static Single Assignment Book + ;; Originally based on: Static Single Assignment Book ;; Algorithm 3.1: Standard algorithm for inserting phi-functions (cl-flet ((add-phi (slot-n bb) ;; Add a phi func for slot SLOT-N at the top of BB. @@ -1135,6 +1135,27 @@ Top level forms for the current context are rendered too." (unless (cl-find y defs-v) (push y w))))))))) +(defun comp-dominator-tree-walker (bb pre-lambda post-lambda) + "Dominator tree walker function starting from basic block BB. +PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non nil." + (when pre-lambda + (funcall pre-lambda bb)) + (when-let ((out-edges (comp-block-out-edges bb))) + (cl-loop for ed in out-edges + for child = (comp-edge-dst ed) + when (eq bb (comp-block-dom child)) + ;; Current block is the immediate dominator the recur. + do (comp-dominator-tree-walker child pre-lambda post-lambda))) + (when post-lambda + (funcall post-lambda bb))) + +(defun comp-rename-mvars () + "Rename all mvar accoring to the new SSA rapresentation." + ;; Originally based on: Static Single Assignment Book + ;; Algorithm 3.3: Renaming algorithm + (comp-dominator-tree-walker (gethash 'entry (comp-func-blocks comp-func)) nil + (lambda (bb) (comp-log (format "\n%s" (comp-block-name bb)))))) + (defun comp-ssa (funcs) "Port FUNCS into mininal SSA form." (cl-loop for comp-func in funcs @@ -1147,7 +1168,8 @@ Top level forms for the current context are rendered too." (comp-compute-dominator-frontiers) (comp-log-block-info) (comp-place-phis) - (comp-log-func comp-func)))) + (comp-log-func comp-func) + (comp-rename-mvars)))) ;;; Final pass specific code. commit e4b32e3c572ef0786d2e6215ceeffb21d6046177 Author: Andrea Corallo Date: Sat Sep 14 12:39:53 2019 +0200 place phis diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 60a4c0ff00..30381e5fd4 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -61,6 +61,9 @@ (defconst comp-known-ret-types '((cons . cons)) "Alist used for type propagation.") +(defconst comp-limple-assignments '(set setimm set-par-to-local) + "Limple operators used to assign to mvars.") + (defconst comp-mostly-pure-funcs '(% * + - / /= 1+ 1- < <= = > >= cons list % concat logand logcount logior lognot logxor regexp-opt regexp-quote string-to-char string-to-syntax @@ -134,7 +137,7 @@ into it.") (dom nil :type comp-block :documentation "Immediate dominator.") (df (make-hash-table) :type hash-table - :documentation "Dominance frontier set. Block -> block-name") + :documentation "Dominance frontier set. Block-name -> block") (post-num nil :type number :documentation "Post order number.")) @@ -178,11 +181,16 @@ structure.") LIMPLE basic block.") (edges () :type list :documentation "List of edges connecting basic blocks.") - (edge-cnt-gen (funcall #'comp-gen-counter) :type number + (edge-cnt-gen (funcall #'comp-gen-counter) :type function :documentation "Generates edges numbers.") - (ssa-cnt-gen (funcall #'comp-gen-counter) :type number + (ssa-cnt-gen (funcall #'comp-gen-counter) :type function :documentation "Counter to create ssa limple vars.")) +(defun comp-func-reset-generators (func) + "Reset unique id generators for FUNC." + (setf (comp-func-edge-cnt-gen func) (comp-gen-counter)) + (setf (comp-func-ssa-cnt-gen func) (comp-gen-counter))) + (cl-defstruct (comp-mvar (:copier nil) (:constructor make--comp-mvar)) "A meta-variable being a slot in the meta-stack." (id nil :type number @@ -261,7 +269,7 @@ BODY is evaluate only if `comp-debug' is non nil." (cl-loop for block-name being each hash-keys of (comp-func-blocks func) using (hash-value bb) do (progn - (comp-log (concat "\n<" (symbol-name block-name) ">")) + (comp-log (concat "\n<" (symbol-name block-name) ">\n")) (comp-log (comp-block-insns bb))))) (defun comp-log-edges (func) @@ -486,7 +494,7 @@ If DST-N is specified use it otherwise assume it to be the current slot." (setf (comp-slot) (copy-sequence src-slot)) (setf (comp-mvar-slot (comp-slot)) (comp-sp)) - (comp-emit (list 'set (comp-slot) src-slot))))) + (comp-emit `(set ,(comp-slot) ,src-slot))))) (defun comp-emit-annotation (str) "Emit annotation STR." @@ -1033,6 +1041,7 @@ Top level forms for the current context are rendered too." (if-let ((p (cl-find-if (lambda (p) (comp-block-dom p)) l))) p (error "Cant't find first preprocessed")))) + (when-let ((blocks (comp-func-blocks comp-func)) (entry (gethash 'entry blocks)) ;; No point to go on if the only bb is 'entry'. @@ -1088,16 +1097,57 @@ Top level forms for the current context are rendered too." collect b))))) (comp-func-blocks comp-func))) +(defun comp-place-phis () + "Place phi insns into the current function." + ;; Static Single Assignment Book + ;; Algorithm 3.1: Standard algorithm for inserting phi-functions + (cl-flet ((add-phi (slot-n bb) + ;; Add a phi func for slot SLOT-N at the top of BB. + (push `(phi ,slot-n) (comp-block-insns bb))) + (slot-assigned-p (slot-n bb) + ;; Return t if a SLOT-N was assigned within BB. + (cl-loop for insn in (comp-block-insns bb) + for op = (car insn) + when (and (cl-find op comp-limple-assignments) + (= slot-n (comp-mvar-slot (cadr insn)))) + do (return t)))) + + (cl-loop for i from 0 below (comp-func-frame-size comp-func) + ;; List of blocks with a definition of mvar i + with defs-v = (cl-loop with blocks = (comp-func-blocks comp-func) + for b being each hash-value of blocks + when (slot-assigned-p i b) + collect b) + ;; Set of basic blocks where phi is added. + with f = () + ;; Worklist, set of basic blocks that contain definitions of v. + with w = defs-v + do + (while w + (let ((x (pop w))) + (cl-loop for y being each hash-value of (comp-block-df x) + unless (cl-find y f) + do (progn + (add-phi i y) + (push y f) + ;; Adding a phi implies mentioning the + ;; correspondig slot so in case adjust w. + (unless (cl-find y defs-v) + (push y w))))))))) + (defun comp-ssa (funcs) "Port FUNCS into mininal SSA form." (cl-loop for comp-func in funcs do (progn - ;; TODO: if run more than once should clean all CFG data - ;; plus phis here. + ;; TODO: if this is run more than once we should clean all CFG + ;; data including phis here. + (comp-func-reset-generators comp-func) (comp-compute-edges) (comp-compute-dominator-tree) (comp-compute-dominator-frontiers) - (comp-log-block-info)))) + (comp-log-block-info) + (comp-place-phis) + (comp-log-func comp-func)))) ;;; Final pass specific code. commit deeae4c415166eb144d008f0e904ffa70034c146 Author: Andrea Corallo Date: Sat Sep 14 10:52:57 2019 +0200 some code massage + doc into the SSA pass diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 38a084f4d3..60a4c0ff00 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -957,43 +957,47 @@ Top level forms for the current context are rendered too." ;;; SSA pass specific code. - -(defun comp-block-add (&rest args) - (push - (apply #'make--comp-edge - :number (funcall (comp-func-edge-cnt-gen comp-func)) - args) - (comp-func-edges comp-func))) +;; After limplification no edges are present between basic blocks and an +;; implicit phi is present for every slot at the beginning of every basic block. +;; This pass is responsible for building all the edges and replace all m-vars +;; plus placing the needed phis. +;; Becase the number of phis placed is (supposed) to be the minimum necessary +;; this form is called 'minimal SSA form'. +;; This pass should be run every time basic blocks or mvar are shuffled. (defun comp-compute-edges () "Compute the basic block edges for the current function." - (cl-loop with blocks = (comp-func-blocks comp-func) - for bb being each hash-value of blocks - for last-insn = (car (last (comp-block-insns bb))) - for (op first _ third forth) = last-insn - do (cl-ecase op - (jump - (comp-block-add :src bb - :dst (gethash first - blocks))) - (cond-jump - (comp-block-add :src bb - :dst (gethash third - blocks)) - (comp-block-add :src bb - :dst (gethash forth - blocks))) - (return)) - finally (progn - (setf (comp-func-edges comp-func) - (nreverse (comp-func-edges comp-func))) - ;; Update edge refs into blocks. - (cl-loop for edge in (comp-func-edges comp-func) - do (push edge - (comp-block-out-edges (comp-edge-src edge))) - do (push edge - (comp-block-in-edges (comp-edge-dst edge)))) - (comp-log-edges comp-func)))) + (cl-flet ((edge-add (&rest args) + (push + (apply #'make--comp-edge + :number (funcall (comp-func-edge-cnt-gen comp-func)) + args) + (comp-func-edges comp-func)))) + + (cl-loop with blocks = (comp-func-blocks comp-func) + for bb being each hash-value of blocks + for last-insn = (car (last (comp-block-insns bb))) + for (op first _ third forth) = last-insn + do (cl-ecase op + (jump + (edge-add :src bb :dst (gethash first + blocks))) + (cond-jump + (edge-add :src bb :dst (gethash third + blocks)) + (edge-add :src bb :dst (gethash forth + blocks))) + (return)) + finally (progn + (setf (comp-func-edges comp-func) + (nreverse (comp-func-edges comp-func))) + ;; Update edge refs into blocks. + (cl-loop for edge in (comp-func-edges comp-func) + do (push edge + (comp-block-out-edges (comp-edge-src edge))) + do (push edge + (comp-block-in-edges (comp-edge-dst edge)))) + (comp-log-edges comp-func))))) (defun comp-collect-rev-post-order (basic-block) "Walk BASIC-BLOCK childs and return their name in reversed post-oder." @@ -1031,7 +1035,7 @@ Top level forms for the current context are rendered too." (error "Cant't find first preprocessed")))) (when-let ((blocks (comp-func-blocks comp-func)) (entry (gethash 'entry blocks)) - ;; No point to go on if the onli bb is entry. + ;; No point to go on if the only bb is 'entry'. (bb1 (gethash 'bb-1 blocks))) (cl-loop with rev-bb-list = (comp-collect-rev-post-order entry) with changed = t @@ -1075,17 +1079,21 @@ Top level forms for the current context are rendered too." (defun comp-log-block-info () "Log basic blocks info for the current function." (maphash (lambda (name bb) - (let ((dom (comp-block-dom bb))) + (let ((dom (comp-block-dom bb)) + (df (comp-block-df bb))) (comp-log (format "block: %s idom: %s DF %s\n" name (when dom (comp-block-name dom)) - (cl-loop for b being each hash-keys of (comp-block-df bb) + (cl-loop for b being each hash-keys of df collect b))))) (comp-func-blocks comp-func))) (defun comp-ssa (funcs) + "Port FUNCS into mininal SSA form." (cl-loop for comp-func in funcs do (progn + ;; TODO: if run more than once should clean all CFG data + ;; plus phis here. (comp-compute-edges) (comp-compute-dominator-tree) (comp-compute-dominator-frontiers) commit 634f71a2238b9e29d6bcab196092edfef19ebaef Author: Andrea Corallo Date: Sat Sep 14 10:13:38 2019 +0200 add dominator frontiers computation diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index a153e46dac..38a084f4d3 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -126,12 +126,15 @@ into it.") :documentation "If the block was already closed.") (insns () :type list :documentation "List of instructions.") + ;; All the followings are for SSA and CGF analysis. (in-edges () :type list :documentation "List of incoming edges.") (out-edges () :type list :documentation "List of outcoming edges.") (dom nil :type comp-block :documentation "Immediate dominator.") + (df (make-hash-table) :type hash-table + :documentation "Dominance frontier set. Block -> block-name") (post-num nil :type number :documentation "Post order number.")) @@ -997,13 +1000,13 @@ Top level forms for the current context are rendered too." (let ((visited (make-hash-table)) (acc ())) (cl-labels ((collect-rec (bb) - (let ((name (comp-block-name bb))) - (unless (gethash name visited) - (puthash name t visited) - (cl-loop for e in (comp-block-out-edges bb) - for dst-block = (comp-edge-dst e) - do (collect-rec dst-block)) - (push name acc))))) + (let ((name (comp-block-name bb))) + (unless (gethash name visited) + (puthash name t visited) + (cl-loop for e in (comp-block-out-edges bb) + for dst-block = (comp-edge-dst e) + do (collect-rec dst-block)) + (push name acc))))) (collect-rec basic-block) acc))) @@ -1045,26 +1048,48 @@ Top level forms for the current context are rendered too." for name in (cdr rev-bb-list) for b = (gethash name blocks) for preds = (comp-block-preds b) - for new-idiom = (first-processed preds) + for new-idom = (first-processed preds) initially (setf changed nil) - do (cl-loop for p in (delq new-idiom preds) + do (cl-loop for p in (delq new-idom preds) when (comp-block-dom p) - do (setf new-idiom (intersect p new-idiom))) - unless (eq (comp-block-dom b) new-idiom) + do (setf new-idom (intersect p new-idom))) + unless (eq (comp-block-dom b) new-idom) do (progn - (setf (comp-block-dom b) new-idiom) - (setf changed t)))))) + (setf (comp-block-dom b) new-idom) + (setf changed t))))))) + +(defun comp-compute-dominator-frontiers () + ;; Again from : "A Simple, Fast Dominance Algorithm" + ;; Cooper, Keith D.; Harvey, Timothy J.; Kennedy, Ken (2001). + (cl-loop with blocks = (comp-func-blocks comp-func) + for b-name being each hash-keys of blocks + using (hash-value b) + for preds = (comp-block-preds b) + when (>= (length preds) 2) ; All joins + do (cl-loop for p in preds + for runner = p + do (while (not (eq runner (comp-block-dom b))) + (puthash b-name b (comp-block-df runner)) + (setf runner (comp-block-dom runner)))))) + +(defun comp-log-block-info () + "Log basic blocks info for the current function." (maphash (lambda (name bb) - (comp-log (format "block: %s dominator: %s\n" - name - (comp-block-name (comp-block-dom bb))))) + (let ((dom (comp-block-dom bb))) + (comp-log (format "block: %s idom: %s DF %s\n" + name + (when dom (comp-block-name dom)) + (cl-loop for b being each hash-keys of (comp-block-df bb) + collect b))))) (comp-func-blocks comp-func))) (defun comp-ssa (funcs) (cl-loop for comp-func in funcs do (progn (comp-compute-edges) - (comp-compute-dominator-tree)))) + (comp-compute-dominator-tree) + (comp-compute-dominator-frontiers) + (comp-log-block-info)))) ;;; Final pass specific code. commit e39f5e5c806dc0f7ee0f3520993ba061af7cb040 Author: Andrea Corallo Date: Fri Sep 13 20:56:24 2019 +0200 compute dominator tree diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index c0796417b4..a153e46dac 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -125,7 +125,15 @@ into it.") (closed nil :type boolean :documentation "If the block was already closed.") (insns () :type list - :documentation "List of instructions.")) + :documentation "List of instructions.") + (in-edges () :type list + :documentation "List of incoming edges.") + (out-edges () :type list + :documentation "List of outcoming edges.") + (dom nil :type comp-block + :documentation "Immediate dominator.") + (post-num nil :type number + :documentation "Post order number.")) (cl-defstruct (comp-edge (:copier nil) (:constructor make--comp-edge)) "An edge connecting two basic blocks." @@ -135,6 +143,10 @@ into it.") :documentation "The index number corresponding to this edge in the edge vector.")) +(defun comp-block-preds (basic-block) + "Given BASIC-BLOCK return the list of its predecessors." + (mapcar #'comp-edge-src (comp-block-in-edges basic-block))) + (defun comp-gen-counter () "Return a sequential number generator." (let ((n -1)) @@ -553,7 +565,7 @@ If NEGATED non nil negate the tested condition." (defun comp-new-block-sym () "Return a symbol naming the next new basic block." - (intern (format "bb_%s" (hash-table-count (comp-func-blocks comp-func))))) + (intern (format "bb-%s" (hash-table-count (comp-func-blocks comp-func))))) (defun comp-lap-to-limple-bb (n) "Given the LAP label N return the limple basic block." @@ -930,7 +942,7 @@ This will be called at runtime." (comp-emit-narg-prologue args-min nonrest) (cl-incf (comp-sp) (1+ nonrest)))) ;; Body - (comp-emit-block 'bb_1) + (comp-emit-block 'bb-1) (mapc #'comp-limplify-lap-inst (comp-func-lap func)) (comp-limplify-finalize-function func))) @@ -943,39 +955,116 @@ Top level forms for the current context are rendered too." ;;; SSA pass specific code. -;; Cooper, Keith D.; Harvey, Timothy J.; Kennedy, Ken (2001). -;; "A Simple, Fast Dominance Algorithm". - (defun comp-block-add (&rest args) (push (apply #'make--comp-edge :number (funcall (comp-func-edge-cnt-gen comp-func)) args) - (comp-func-edges comp-func))) + (comp-func-edges comp-func))) + +(defun comp-compute-edges () + "Compute the basic block edges for the current function." + (cl-loop with blocks = (comp-func-blocks comp-func) + for bb being each hash-value of blocks + for last-insn = (car (last (comp-block-insns bb))) + for (op first _ third forth) = last-insn + do (cl-ecase op + (jump + (comp-block-add :src bb + :dst (gethash first + blocks))) + (cond-jump + (comp-block-add :src bb + :dst (gethash third + blocks)) + (comp-block-add :src bb + :dst (gethash forth + blocks))) + (return)) + finally (progn + (setf (comp-func-edges comp-func) + (nreverse (comp-func-edges comp-func))) + ;; Update edge refs into blocks. + (cl-loop for edge in (comp-func-edges comp-func) + do (push edge + (comp-block-out-edges (comp-edge-src edge))) + do (push edge + (comp-block-in-edges (comp-edge-dst edge)))) + (comp-log-edges comp-func)))) + +(defun comp-collect-rev-post-order (basic-block) + "Walk BASIC-BLOCK childs and return their name in reversed post-oder." + (let ((visited (make-hash-table)) + (acc ())) + (cl-labels ((collect-rec (bb) + (let ((name (comp-block-name bb))) + (unless (gethash name visited) + (puthash name t visited) + (cl-loop for e in (comp-block-out-edges bb) + for dst-block = (comp-edge-dst e) + do (collect-rec dst-block)) + (push name acc))))) + (collect-rec basic-block) + acc))) + +(defun comp-compute-dominator-tree () + "Compute immediate dominators for each basic block in current function." + ;; Cooper, Keith D.; Harvey, Timothy J.; Kennedy, Ken (2001). + ;; "A Simple, Fast Dominance Algorithm". + (cl-flet ((intersect (b1 b2) + (let ((finger1 (comp-block-post-num b1)) + (finger2 (comp-block-post-num b2))) + (while (not (= finger1 finger2)) + (while (< finger1 finger2) + (setf b1 (comp-block-dom b1)) + (setf finger1 (comp-block-post-num b1))) + (while (< finger2 finger1) + (setf b2 (comp-block-dom b2)) + (setf finger2 (comp-block-post-num b2)))) + b1)) + (first-processed (l) + (if-let ((p (cl-find-if (lambda (p) (comp-block-dom p)) l))) + p + (error "Cant't find first preprocessed")))) + (when-let ((blocks (comp-func-blocks comp-func)) + (entry (gethash 'entry blocks)) + ;; No point to go on if the onli bb is entry. + (bb1 (gethash 'bb-1 blocks))) + (cl-loop with rev-bb-list = (comp-collect-rev-post-order entry) + with changed = t + while changed + initially (progn + (comp-log "Computing dominator tree...\n") + (setf (comp-block-dom entry) entry) + ;; Set the post order number. + (cl-loop for name in (reverse rev-bb-list) + for b = (gethash name blocks) + for i from 0 + do (setf (comp-block-post-num b) i))) + do (cl-loop + for name in (cdr rev-bb-list) + for b = (gethash name blocks) + for preds = (comp-block-preds b) + for new-idiom = (first-processed preds) + initially (setf changed nil) + do (cl-loop for p in (delq new-idiom preds) + when (comp-block-dom p) + do (setf new-idiom (intersect p new-idiom))) + unless (eq (comp-block-dom b) new-idiom) + do (progn + (setf (comp-block-dom b) new-idiom) + (setf changed t)))))) + (maphash (lambda (name bb) + (comp-log (format "block: %s dominator: %s\n" + name + (comp-block-name (comp-block-dom bb))))) + (comp-func-blocks comp-func))) (defun comp-ssa (funcs) - (cl-loop for comp-func in funcs do - (cl-loop with blocks = (comp-func-blocks comp-func) - for bb being each hash-value of blocks - for last-insn = (car (last (comp-block-insns bb))) - for (op first _ third forth) = last-insn - do (cl-ecase op - (jump (comp-block-add :src bb - :dst (gethash first - blocks))) - (cond-jump - (progn - (comp-block-add :src bb - :dst (gethash third - blocks)) - (comp-block-add :src bb - :dst (gethash forth - blocks)))) - (return)) - finally (progn - (setf (comp-func-edges comp-func) - (nreverse (comp-func-edges comp-func))) - (comp-log-edges comp-func))))) + (cl-loop for comp-func in funcs + do (progn + (comp-compute-edges) + (comp-compute-dominator-tree)))) ;;; Final pass specific code. commit 03045e2e73eba5578218e09127055ab07a7c398b Author: Andrea Corallo Date: Fri Sep 13 17:55:16 2019 +0200 ssa and endge number generation with generator diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 3e77c8a083..c0796417b4 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -127,6 +127,20 @@ into it.") (insns () :type list :documentation "List of instructions.")) +(cl-defstruct (comp-edge (:copier nil) (:constructor make--comp-edge)) + "An edge connecting two basic blocks." + (src nil :type comp-block) + (dst nil :type comp-block) + (number nil :type number + :documentation "The index number corresponding to this edge in the + edge vector.")) + +(defun comp-gen-counter () + "Return a sequential number generator." + (let ((n -1)) + (lambda () + (cl-incf n)))) + (cl-defstruct (comp-func (:copier nil)) "LIMPLE representation of a function." (symbol-name nil @@ -149,9 +163,9 @@ structure.") LIMPLE basic block.") (edges () :type list :documentation "List of edges connecting basic blocks.") - (edges-n 0 :type number - :documentation "In use just to generate edges numbers.") - (ssa-cnt -1 :type number + (edge-cnt-gen (funcall #'comp-gen-counter) :type number + :documentation "Generates edges numbers.") + (ssa-cnt-gen (funcall #'comp-gen-counter) :type number :documentation "Counter to create ssa limple vars.")) (cl-defstruct (comp-mvar (:copier nil) (:constructor make--comp-mvar)) @@ -375,7 +389,7 @@ If INPUT is a string this is the file path to be compiled." (cl-defun make-comp-mvar (&key slot (constant nil const-vld) type) (when const-vld (comp-add-const-to-relocs constant)) - (make--comp-mvar :id (cl-incf (comp-func-ssa-cnt comp-func)) + (make--comp-mvar :id (funcall (comp-func-ssa-cnt-gen comp-func)) :slot slot :const-vld const-vld :constant constant :type type)) @@ -487,7 +501,7 @@ If DST-N is specified use it otherwise assume it to be the current slot." (let ((blocks (comp-func-blocks comp-func))) ;; In case does not exist register it into comp-func-blocks. (comp-block-maybe-add :name block-name - :sp (comp-sp)) + :sp (comp-sp)) ;; If we are abandoning an non closed basic block close it with a fall ;; through. (when (and (not (eq block-name 'entry)) @@ -929,17 +943,14 @@ Top level forms for the current context are rendered too." ;;; SSA pass specific code. -(cl-defstruct (comp-edge (:copier nil) (:constructor make--comp-edge)) - "An edge connecting two basic blocks." - (src nil :type comp-block) - (dst nil :type comp-block) - (number nil :type number - :documentation "The index number corresponding to this edge in the - edge vector.")) +;; Cooper, Keith D.; Harvey, Timothy J.; Kennedy, Ken (2001). +;; "A Simple, Fast Dominance Algorithm". -(cl-defun comp-block-add (&rest args &key &allow-other-keys) - (push (apply #'make--comp-edge - :number (cl-incf (comp-func-edges-n comp-func)) args) +(defun comp-block-add (&rest args) + (push + (apply #'make--comp-edge + :number (funcall (comp-func-edge-cnt-gen comp-func)) + args) (comp-func-edges comp-func))) (defun comp-ssa (funcs) commit c158b52ea421b4ea49adb79c445b712d18ad8273 Author: Andrea Corallo Date: Wed Sep 11 23:13:13 2019 +0200 add edge computation diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index deeff88d26..3e77c8a083 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -54,6 +54,7 @@ (defconst comp-passes '(comp-spill-lap comp-limplify + comp-ssa comp-final) "Passes to be executed in order.") @@ -146,6 +147,10 @@ structure.") (lap-block (make-hash-table :test #'equal) :type hash-table :documentation "Key value to convert from LAP label number to LIMPLE basic block.") + (edges () :type list + :documentation "List of edges connecting basic blocks.") + (edges-n 0 :type number + :documentation "In use just to generate edges numbers.") (ssa-cnt -1 :type number :documentation "Counter to create ssa limple vars.")) @@ -230,6 +235,17 @@ BODY is evaluate only if `comp-debug' is non nil." (comp-log (concat "\n<" (symbol-name block-name) ">")) (comp-log (comp-block-insns bb))))) +(defun comp-log-edges (func) + "Log edges in FUNC." + (let ((edges (comp-func-edges func))) + (comp-log (format "\nEdges in function: %s\n" (comp-func-symbol-name func))) + (mapc (lambda (e) + (comp-log (format "n: %d src: %s dst: %s\n" + (comp-edge-number e) + (comp-block-name (comp-edge-src e)) + (comp-block-name (comp-edge-dst e))))) + edges))) + ;;; spill-lap pass specific code. @@ -910,6 +926,46 @@ Top level forms for the current context are rendered too." (cons (comp-limplify-top-level) (mapcar #'comp-limplify-function funcs))) + +;;; SSA pass specific code. + +(cl-defstruct (comp-edge (:copier nil) (:constructor make--comp-edge)) + "An edge connecting two basic blocks." + (src nil :type comp-block) + (dst nil :type comp-block) + (number nil :type number + :documentation "The index number corresponding to this edge in the + edge vector.")) + +(cl-defun comp-block-add (&rest args &key &allow-other-keys) + (push (apply #'make--comp-edge + :number (cl-incf (comp-func-edges-n comp-func)) args) + (comp-func-edges comp-func))) + +(defun comp-ssa (funcs) + (cl-loop for comp-func in funcs do + (cl-loop with blocks = (comp-func-blocks comp-func) + for bb being each hash-value of blocks + for last-insn = (car (last (comp-block-insns bb))) + for (op first _ third forth) = last-insn + do (cl-ecase op + (jump (comp-block-add :src bb + :dst (gethash first + blocks))) + (cond-jump + (progn + (comp-block-add :src bb + :dst (gethash third + blocks)) + (comp-block-add :src bb + :dst (gethash forth + blocks)))) + (return)) + finally (progn + (setf (comp-func-edges comp-func) + (nreverse (comp-func-edges comp-func))) + (comp-log-edges comp-func))))) + ;;; Final pass specific code. commit 89c144b83077aea584e9bbbf04e1d786220aec4c Author: Andrea Corallo Date: Wed Sep 11 22:18:41 2019 +0200 rename comp-ctxt-funcs comp-ctxt-exp-funcs diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 17a8a7ef9f..deeff88d26 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -84,9 +84,9 @@ (output nil :type 'string :documentation "Target output filename for the compilation.") (top-level-defvars nil :type list - :documentation "List of top level form to be compiled.") - (funcs () :type list - :documentation "Exported functions list.") + :documentation "List of top level form to be exp.") + (exp-funcs () :type list + :documentation "Exported functions list.") (funcs-h (make-hash-table) :type hash-table :documentation "lisp-func-name -> comp-func. This is to build the prev field.") @@ -918,7 +918,7 @@ Top level forms for the current context are rendered too." Prepare every functions for final compilation and drive the C side." (cl-assert (= (length (comp-ctxt-data-relocs-l comp-ctxt)) (hash-table-count (comp-ctxt-data-relocs-idx comp-ctxt)))) - (setf (comp-ctxt-funcs comp-ctxt) + (setf (comp-ctxt-exp-funcs comp-ctxt) (cl-loop with h = (comp-ctxt-funcs-h comp-ctxt) for f being each hash-value of h for args = (comp-func-args f) diff --git a/src/comp.c b/src/comp.c index 33ed4d6397..1c201c16c9 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1801,7 +1801,7 @@ emit_ctxt_code (void) IMPORTED_FUNC_RELOC_SYM); /* Exported functions info. */ - Lisp_Object func_list = FUNCALL1 (comp-ctxt-funcs, Vcomp_ctxt); + Lisp_Object func_list = FUNCALL1 (comp-ctxt-exp-funcs, Vcomp_ctxt); emit_static_object (TEXT_EXPORTED_FUNC_RELOC_SYM, func_list); SAFE_FREE (); } commit d6d5062bbae5ee708a0b80ad9b5f400320239fcc Author: Andrea Corallo Date: Wed Sep 11 21:56:26 2019 +0200 rework comp-new-frame diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 4e3f0c91e3..17a8a7ef9f 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -351,10 +351,10 @@ If INPUT is a string this is the file path to be compiled." (defun comp-new-frame (size) "Return a clean frame of meta variables of size SIZE." - (let ((v (make-vector size nil))) - (cl-loop for i below size - do (aset v i (make-comp-mvar :slot i))) - v)) + (cl-loop with v = (make-vector size nil) + for i below size + do (aset v i (make-comp-mvar :slot i)) + finally (return v))) (cl-defun make-comp-mvar (&key slot (constant nil const-vld) type) (when const-vld commit 7edbb163b322072da6666240a698b5dc5fc6aaef Author: Andrea Corallo Date: Wed Sep 11 21:51:37 2019 +0200 rework basic block creation diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index bbef9fc379..4e3f0c91e3 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -114,9 +114,10 @@ To be used when ncall-conv is nil.")) (nonrest nil :type number :documentation "Number of non rest arguments.")) -(cl-defstruct (comp-block (:copier nil)) +(cl-defstruct (comp-block (:copier nil) (:constructor make--comp-block)) "A basic block." - ;; The first two slots are used during limplification. + (name nil :type symbol) + ;; These two slots are used during limplification. (sp nil :documentation "When non nil indicates the sp value while entering into it.") @@ -326,6 +327,11 @@ If INPUT is a string this is the file path to be compiled." (defvar comp-block) (defvar comp-func) +(cl-defun comp-block-maybe-add (&rest args &key name &allow-other-keys) + (let ((blocks (comp-func-blocks comp-func))) + (unless (gethash name blocks) + (puthash name (apply #'make--comp-block args) blocks)))) + ;; (defun comp-opt-call (inst) ;; "Optimize if possible a side-effect-free call in INST." ;; (cl-destructuring-bind (_ f &rest args) inst @@ -464,10 +470,8 @@ If DST-N is specified use it otherwise assume it to be the current slot." "Emit basic block BLOCK-NAME." (let ((blocks (comp-func-blocks comp-func))) ;; In case does not exist register it into comp-func-blocks. - (unless (gethash block-name blocks) - (puthash block-name - (make-comp-block :sp (comp-sp)) - blocks)) + (comp-block-maybe-add :name block-name + :sp (comp-sp)) ;; If we are abandoning an non closed basic block close it with a fall ;; through. (when (and (not (eq block-name 'entry)) @@ -491,20 +495,13 @@ If DST-N is specified use it otherwise assume it to be the current slot." TARGET-OFFSET is the positive offset on the SP when branching to the target block. If NEGATED non nil negate the tested condition." - (let ((blocks (comp-func-blocks comp-func)) - (bb (comp-new-block-sym))) ;; Fall through block - (puthash bb - (make-comp-block :sp (comp-sp)) - blocks) + (let ((bb (comp-new-block-sym))) ;; Fall through block + (comp-block-maybe-add :name bb :sp (comp-sp)) (let ((target (comp-lap-to-limple-bb lap-label))) (comp-emit (if negated (list 'cond-jump a b target bb) (list 'cond-jump a b bb target))) - (unless (gethash target blocks) - ;; Create the bb target only if does not exixsts already. - (puthash target - (make-comp-block :sp (+ target-offset (comp-sp))) - blocks)) + (comp-block-maybe-add :name target :sp (+ target-offset (comp-sp))) (comp-mark-block-closed)) (comp-emit-block bb))) @@ -540,21 +537,16 @@ If NEGATED non nil negate the tested condition." (defun comp-emit-handler (guarded-label handler-type) "Emit a non local exit handler for GUARDED-LABEL of type HANDLER-TYPE." - (let ((blocks (comp-func-blocks comp-func)) - (guarded-bb (comp-new-block-sym))) - (puthash guarded-bb - (make-comp-block :sp (comp-sp)) - blocks) - (let ((handler-bb (comp-lap-to-limple-bb guarded-label))) - (comp-emit (list 'push-handler (comp-slot+1) - handler-type - handler-bb - guarded-bb)) - (puthash handler-bb - (make-comp-block :sp (1+ (comp-sp))) - blocks) - (comp-mark-block-closed) - (comp-emit-block guarded-bb)))) + (let ((guarded-bb (comp-new-block-sym))) + (comp-block-maybe-add :name guarded-bb :sp (comp-sp)) + (let ((handler-bb (comp-lap-to-limple-bb guarded-label))) + (comp-emit (list 'push-handler (comp-slot+1) + handler-type + handler-bb + guarded-bb)) + (comp-block-maybe-add :name handler-bb :sp (1+ (comp-sp))) + (comp-mark-block-closed) + (comp-emit-block guarded-bb)))) (defun comp-emit-switch (var m-hash) "Emit a limple for a lap jump table given VAR and M-HASH." commit 77e80ae0136d1d79c0ee33b9780445aa6498664d Author: Andrea Corallo Date: Mon Sep 9 19:43:12 2019 +0200 fix missing cl- prefix in comp.el diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index c398810186..bbef9fc379 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -290,7 +290,7 @@ Put PREFIX in front of it." (byte-compile-file filename) (setf (comp-ctxt-top-level-defvars comp-ctxt) (reverse (mapcar (lambda (x) - (ecase (car x) + (cl-ecase (car x) ('defvar (cdr x)) ('defconst (cdr x)))) byte-to-native-top-level-forms))) commit 6a69e49f01fdd025912e2d4397ebe2f51e3f188d Author: Andrea Corallo Date: Mon Sep 9 22:56:09 2019 +0200 style nit diff --git a/src/comp.c b/src/comp.c index 98932f79bb..33ed4d6397 100644 --- a/src/comp.c +++ b/src/comp.c @@ -2699,9 +2699,9 @@ compile_function (Lisp_Object func) frame_size), "local"); - gcc_jit_lvalue **frame = SAFE_ALLOCA (frame_size * sizeof (*frame)); + comp.frame = SAFE_ALLOCA (frame_size * sizeof (*comp.frame)); for (int i = 0; i < frame_size; ++i) - frame[i] = + comp.frame[i] = gcc_jit_context_new_array_access ( comp.ctxt, NULL, @@ -2709,7 +2709,6 @@ compile_function (Lisp_Object func) gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.int_type, i)); - comp.frame = frame; comp.func_blocks = CALLN (Fmake_hash_table); commit 59035c17d08f0999ba96c74d1763eedb0347d11e Author: Andrea Corallo Date: Mon Sep 9 21:39:03 2019 +0200 add test for recursive calls diff --git a/test/src/comp-test-funcs.el b/test/src/comp-test-funcs.el index dbc9077177..e43db6973b 100644 --- a/test/src/comp-test-funcs.el +++ b/test/src/comp-test-funcs.el @@ -221,6 +221,12 @@ (defun comp-tests-lambda-return-f () (lambda (x) (1+ x))) +(defun comp-tests-fib-f (n) + (cond ((= n 0) 0) + ((= n 1) 1) + (t (+ (comp-tests-fib-f (- n 1)) + (comp-tests-fib-f (- n 2)))))) + ;;;;;;;;;;;;;;;;;;;; ;; Tromey's tests ;; ;;;;;;;;;;;;;;;;;;;; diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 4f4005bea6..16726cb4bb 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -262,6 +262,9 @@ (ert-deftest comp-tests-lambda-return () (should (= (funcall (comp-tests-lambda-return-f) 3) 4))) +(ert-deftest comp-tests-recursive () + (should (= (comp-tests-fib-f 10) 55))) + ;;;;;;;;;;;;;;;;;;;; ;; Tromey's tests ;; ;;;;;;;;;;;;;;;;;;;; commit 24dcbf47d826f46821ed484f93ffb89d306a0b2d Author: Andrea Corallo Date: Mon Sep 9 21:35:31 2019 +0200 fix broken selfcall optimization diff --git a/src/comp.c b/src/comp.c index f966a2427b..98932f79bb 100644 --- a/src/comp.c +++ b/src/comp.c @@ -147,6 +147,7 @@ typedef struct { gcc_jit_field *cast_union_as_lisp_obj; gcc_jit_field *cast_union_as_lisp_obj_ptr; gcc_jit_function *func; /* Current function being compiled. */ + Lisp_Object lfunc; gcc_jit_block *block; /* Current basic block being compiled. */ gcc_jit_lvalue **frame; /* Frame for the current function. */ gcc_jit_rvalue *most_positive_fixnum; @@ -210,7 +211,7 @@ static void ice (const char* msg) { if (msg) - msg = format_string ("Internal native compiler error: %s", msg); + msg = format_string ("Internal native compiler error: %s", msg); else msg = "Internal native compiler error"; error ("%s", msg); @@ -394,6 +395,16 @@ static gcc_jit_rvalue * emit_call (Lisp_Object subr_sym, gcc_jit_type *ret_type, unsigned nargs, gcc_jit_rvalue **args) { + /* Self call optimization. */ + if (!NILP (comp.lfunc) && + comp_speed >= 2 && + EQ (subr_sym, FUNCALL1 (comp-func-symbol-name, comp.lfunc))) + return gcc_jit_context_new_call (comp.ctxt, + NULL, + comp.func, + nargs, + args); + Lisp_Object value = Fgethash (subr_sym, comp.func_hash, Qnil); ICE_IF (NILP (value), "missing function declaration"); @@ -2651,6 +2662,8 @@ compile_function (Lisp_Object func) EMACS_INT frame_size = XFIXNUM (FUNCALL1 (comp-func-frame-size, func)); bool ncall = (FUNCALL1 (comp-nargs-p, args)); + comp.lfunc = func; + if (!ncall) { EMACS_INT max_args = XFIXNUM (FUNCALL1 (comp-args-max, args)); @@ -2733,6 +2746,7 @@ compile_function (Lisp_Object func) format_string ("failing to compile function %s with error: %s", SSDATA (SYMBOL_NAME (FUNCALL1 (comp-func-symbol-name, func))), err)); + comp.lfunc = Qnil; SAFE_FREE (); } commit 63ecf01d0b0897b948296eaaffd690290d536b72 Author: Andrea Corallo Date: Mon Sep 9 12:55:51 2019 +0200 crank optimizations while running native compiler test suite diff --git a/test/src/comp-test-funcs.el b/test/src/comp-test-funcs.el index 4fc62482a0..dbc9077177 100644 --- a/test/src/comp-test-funcs.el +++ b/test/src/comp-test-funcs.el @@ -185,7 +185,6 @@ (defun comp-tests-err-foo-f () (error "foo")) -;;FIXME: horrible... (defun comp-tests-condition-case-0-f () ;; Bpushhandler Bpophandler (condition-case diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 331e1cfed1..4f4005bea6 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -29,7 +29,7 @@ (require 'cl-lib) (require 'comp) -(setq comp-speed 0) +(setq comp-speed 3) (defconst comp-test-src (concat (file-name-directory (or load-file-name buffer-file-name)) @@ -205,7 +205,7 @@ (ert-deftest comp-tests-bubble-sort () "Run bubble sort." - (let* ((list1 (mapcar 'random (make-list 1000 most-positive-fixnum))) + (let* ((list1 (mapcar #'random (make-list 1000 most-positive-fixnum))) (list2 (copy-sequence list1))) (should (equal (comp-bubble-sort-f list1) (sort list2 #'<))))) commit b9f37a2a09ac6bcef1a03cc49489f15ff01a74b7 Author: Andrea Corallo Date: Mon Sep 9 12:01:03 2019 +0200 pacify gcc and improve sanaity checks diff --git a/src/comp.c b/src/comp.c index 8422c7d343..f966a2427b 100644 --- a/src/comp.c +++ b/src/comp.c @@ -44,8 +44,6 @@ along with GNU Emacs. If not, see . */ generated code C-like code more bloated. */ -#define CONST_PROP_MAX 0 - /* C symbols emited for the load relocation mechanism. */ #define DATA_RELOC_SYM "d_reloc" #define IMPORTED_FUNC_RELOC_SYM "f_reloc" @@ -79,6 +77,12 @@ along with GNU Emacs. If not, see . */ #endif #define SETJMP_NAME STR (SETJMP) +#define ICE_IF(test, msg) \ + do { \ + if (test) \ + ice (msg); \ + } while (0) + /* C side of the compiler context. */ typedef struct { @@ -186,8 +190,7 @@ Lisp_Object helper_save_window_excursion (Lisp_Object v1); void helper_unwind_protect (Lisp_Object handler); Lisp_Object helper_temp_output_buffer_setup (Lisp_Object x); Lisp_Object helper_unbind_n (Lisp_Object n); -bool helper_PSEUDOVECTOR_TYPEP_XUNTAG (const union vectorlike_header *a, - enum pvec_type code); +bool helper_PSEUDOVECTOR_TYPEP_XUNTAG (Lisp_Object a, enum pvec_type code); static char * ATTRIBUTE_FORMAT_PRINTF (1, 2) @@ -203,6 +206,16 @@ format_string (const char *format, ...) return scratch_area; } +static void +ice (const char* msg) +{ + if (msg) + msg = format_string ("Internal native compiler error: %s", msg); + else + msg = "Internal native compiler error"; + error ("%s", msg); +} + static void bcall0 (Lisp_Object f) { @@ -243,7 +256,7 @@ type_to_cast_field (gcc_jit_type *type) else if (type == comp.lisp_obj_ptr_type) field = comp.cast_union_as_lisp_obj_ptr; else - error ("Unsupported cast"); + ice ("unsupported cast"); return field; } @@ -252,8 +265,7 @@ static gcc_jit_block * retrive_block (Lisp_Object block_name) { Lisp_Object value = Fgethash (block_name, comp.func_blocks, Qnil); - if (NILP (value)) - error ("LIMPLE basic block inconsistency"); + ICE_IF (NILP (value), "missing basic block"); return (gcc_jit_block *) xmint_pointer (value); } @@ -264,8 +276,8 @@ declare_block (Lisp_Object block_name) char *name_str = (char *) SDATA (SYMBOL_NAME (block_name)); gcc_jit_block *block = gcc_jit_function_new_block (comp.func, name_str); Lisp_Object value = make_mint_ptr (block); - if (!NILP (Fgethash (block_name, comp.func_blocks, Qnil))) - error ("LIMPLE basic block inconsistency"); + ICE_IF (!NILP (Fgethash (block_name, comp.func_blocks, Qnil)), + "double basic block declaration"); Fputhash (block_name, value, comp.func_blocks); } @@ -295,7 +307,8 @@ declare_imported_func (Lisp_Object subr_sym, gcc_jit_type *ret_type, int nargs, gcc_jit_type **types) { /* Don't want to declare the same function two times. */ - eassert (NILP (Fgethash (subr_sym, comp.func_hash, Qnil))); + ICE_IF (!NILP (Fgethash (subr_sym, comp.func_hash, Qnil)), + "unexpected double function declaration"); if (nargs == MANY) { @@ -317,8 +330,6 @@ declare_imported_func (Lisp_Object subr_sym, gcc_jit_type *ret_type, types[i] = comp.lisp_obj_type; } - eassert (types); - /* String containing the function ptr name. */ Lisp_Object f_ptr_name = CALLN (Ffuncall, intern_c_string (STR (comp-c-func-name)), @@ -359,16 +370,17 @@ static gcc_jit_function * declare_exported_func (const char *f_name, gcc_jit_type *ret_type, unsigned nargs, gcc_jit_rvalue **args) { - gcc_jit_type *type[nargs]; - + USE_SAFE_ALLOCA; + gcc_jit_type **type = SAFE_ALLOCA (nargs * sizeof (*type)); fill_declaration_types (type, args, nargs); - gcc_jit_param *param[nargs]; + gcc_jit_param **param = SAFE_ALLOCA (nargs *sizeof (*param)); for (int i = nargs - 1; i >= 0; i--) param[i] = gcc_jit_context_new_param(comp.ctxt, NULL, type[i], format_string ("par_%d", i)); + SAFE_FREE (); return gcc_jit_context_new_function(comp.ctxt, NULL, GCC_JIT_GLOBAL_EXPORTED, ret_type, @@ -383,14 +395,14 @@ emit_call (Lisp_Object subr_sym, gcc_jit_type *ret_type, unsigned nargs, gcc_jit_rvalue **args) { Lisp_Object value = Fgethash (subr_sym, comp.func_hash, Qnil); - eassert (!NILP (value)); + ICE_IF (NILP (value), "missing function declaration"); gcc_jit_lvalue *f_ptr = gcc_jit_lvalue_access_field (comp.func_relocs, NULL, (gcc_jit_field *) xmint_pointer (value)); - if (!f_ptr) - error ("Undeclared function relocation."); + + ICE_IF (!f_ptr, "undeclared function relocation"); emit_comment (format_string ("calling subr: %s", SSDATA (SYMBOL_NAME (subr_sym)))); @@ -1050,7 +1062,7 @@ emit_set_internal (Lisp_Object args) #s(comp-mvar 6 1 t 3 nil)) */ /* TODO: Inline the most common case. */ - eassert (list_length (args) == 3); + ICE_IF (list_length (args) != 3, "unexpected arg length for insns"); args = XCDR (args); int i = 0; gcc_jit_rvalue *gcc_args[4]; @@ -1069,14 +1081,16 @@ emit_set_internal (Lisp_Object args) static gcc_jit_rvalue * emit_simple_limple_call (Lisp_Object args, gcc_jit_type *ret_type) { + USE_SAFE_ALLOCA; int i = 0; Lisp_Object callee = FIRST (args); args = XCDR (args); ptrdiff_t nargs = list_length (args); - gcc_jit_rvalue *gcc_args[nargs]; + gcc_jit_rvalue **gcc_args = SAFE_ALLOCA (nargs * sizeof (*gcc_args)); FOR_EACH_TAIL (args) gcc_args[i++] = emit_mvar_val (XCAR (args)); + SAFE_FREE (); return emit_call (callee, ret_type, nargs, gcc_args); } @@ -1195,7 +1209,7 @@ emit_limple_insn (Lisp_Object insn) { Lisp_Object op = XCAR (insn); Lisp_Object args = XCDR (insn); - Lisp_Object arg0; + Lisp_Object arg0 UNINIT; gcc_jit_rvalue *res; if (CONSP (args)) @@ -1243,13 +1257,13 @@ emit_limple_insn (Lisp_Object insn) { EMACS_UINT clobber_slot = XFIXNUM (FUNCALL1 (comp-mvar-slot, arg0)); gcc_jit_rvalue *handler = emit_mvar_val (arg0); - int h_num; + int h_num UNINIT; if (EQ (SECOND (args), Qcatcher)) h_num = CATCHER; else if (EQ (SECOND (args), Qcondition_case)) h_num = CONDITION_CASE; else - eassert (false); + ice ("incoherent insn"); gcc_jit_rvalue *handler_type = gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.int_type, @@ -1299,8 +1313,10 @@ emit_limple_insn (Lisp_Object insn) else if (EQ (FIRST (arg1), Qcallref)) res = emit_limple_call_ref (XCDR (arg1)); else - error ("LIMPLE inconsistent arg1 for op ="); - eassert (res); + ice ("LIMPLE inconsistent arg1 for op ="); + + ICE_IF (!res, "incoherent insn"); + gcc_jit_block_add_assignment (comp.block, NULL, comp.frame[slot_n], @@ -1420,7 +1436,7 @@ emit_limple_insn (Lisp_Object insn) } else { - error ("LIMPLE op inconsistent"); + ice ("LIMPLE op inconsistent"); } } @@ -1690,6 +1706,8 @@ This emit the code needed by every compilation unit to be loaded. static void emit_ctxt_code (void) { + USE_SAFE_ALLOCA; + declare_runtime_imported_data (); /* Imported objects. */ EMACS_UINT d_reloc_len = @@ -1720,7 +1738,7 @@ emit_ctxt_code (void) Lisp_Object f_subr = FUNCALL1 (comp-ctxt-func-relocs-l, Vcomp_ctxt); f_reloc_len += XFIXNUM (Flength (f_subr)); - gcc_jit_field *fields[f_reloc_len]; + gcc_jit_field **fields = SAFE_ALLOCA (f_reloc_len * sizeof (*fields)); Lisp_Object f_reloc_list = Qnil; int n_frelocs = 0; @@ -1774,6 +1792,7 @@ emit_ctxt_code (void) /* Exported functions info. */ Lisp_Object func_list = FUNCALL1 (comp-ctxt-funcs, Vcomp_ctxt); emit_static_object (TEXT_EXPORTED_FUNC_RELOC_SYM, func_list); + SAFE_FREE (); } @@ -2626,6 +2645,7 @@ define_bool_to_lisp_obj (void) static void compile_function (Lisp_Object func) { + USE_SAFE_ALLOCA; char *c_name = SSDATA (FUNCALL1 (comp-func-c-func-name, func)); Lisp_Object args = FUNCALL1 (comp-func-args, func); EMACS_INT frame_size = XFIXNUM (FUNCALL1 (comp-func-frame-size, func)); @@ -2666,7 +2686,7 @@ compile_function (Lisp_Object func) frame_size), "local"); - gcc_jit_lvalue *frame[frame_size]; + gcc_jit_lvalue **frame = SAFE_ALLOCA (frame_size * sizeof (*frame)); for (int i = 0; i < frame_size; ++i) frame[i] = gcc_jit_context_new_array_access ( @@ -2698,7 +2718,7 @@ compile_function (Lisp_Object func) Lisp_Object block_name = HASH_KEY (ht, i); Lisp_Object block = HASH_VALUE (ht, i); Lisp_Object insns = FUNCALL1 (comp-block-insns, block); - eassert (!NILP (block) && !NILP (insns)); + ICE_IF (NILP (block) || NILP (insns), "basic block is missing or empty"); comp.block = retrive_block (block_name); while (CONSP (insns)) @@ -2709,10 +2729,11 @@ compile_function (Lisp_Object func) } } const char *err = gcc_jit_context_get_first_error (comp.ctxt); - if (err) - error ("Failing to compile function %s with error:%s", - SSDATA (SYMBOL_NAME (FUNCALL1 (comp-func-symbol-name, func))), - err); + ICE_IF (err, + format_string ("failing to compile function %s with error: %s", + SSDATA (SYMBOL_NAME (FUNCALL1 (comp-func-symbol-name, func))), + err)); + SAFE_FREE (); } @@ -2727,7 +2748,7 @@ DEFUN ("comp--init-ctxt", Fcomp__init_ctxt, Scomp__init_ctxt, { if (comp.ctxt) { - error ("Compiler context already taken"); + ice ("compiler context already taken"); return Qnil; } @@ -3065,8 +3086,7 @@ helper_unbind_n (Lisp_Object n) } bool -helper_PSEUDOVECTOR_TYPEP_XUNTAG (const union vectorlike_header *a, - enum pvec_type code) +helper_PSEUDOVECTOR_TYPEP_XUNTAG (Lisp_Object a, enum pvec_type code) { return PSEUDOVECTOR_TYPEP (XUNTAG (a, Lisp_Vectorlike, union vectorlike_header), @@ -3163,7 +3183,7 @@ load_comp_unit (dynlib_handle_ptr handle) f_relocs[i] = (void *) specbind; } else { - error ("Unexpected function relocation %s", f_str); + ice (format_string ("unexpected function relocation %s", f_str)); } } diff --git a/src/lisp.h b/src/lisp.h index 93a3ddea0c..cb3487675e 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -4742,9 +4742,9 @@ extern void malloc_probe (size_t); extern void syms_of_profiler (void); /* Defined in comp.c. */ -#ifdef HAVE_LIBGCCJIT +#ifdef HAVE_NATIVE_COMP extern void syms_of_comp (void); -#endif /* HAVE_LIBGCCJIT */ +#endif /* HAVE_NATIVE_COMP */ #ifdef DOS_NT /* Defined in msdos.c, w32.c. */ commit c702e25a7a9e1ba2b75942dcc00402947757786d Author: Andrea Corallo Date: Sun Sep 8 21:42:51 2019 +0200 do not override existing basic blocks when branching backwards! diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 0770d32f7a..c398810186 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -500,9 +500,11 @@ If NEGATED non nil negate the tested condition." (comp-emit (if negated (list 'cond-jump a b target bb) (list 'cond-jump a b bb target))) - (puthash target - (make-comp-block :sp (+ target-offset (comp-sp))) - blocks) + (unless (gethash target blocks) + ;; Create the bb target only if does not exixsts already. + (puthash target + (make-comp-block :sp (+ target-offset (comp-sp))) + blocks)) (comp-mark-block-closed)) (comp-emit-block bb))) commit 5f1039630dc8bf63f65df5c7882246f267d01295 Author: Andrea Corallo Date: Sun Sep 8 21:42:37 2019 +0200 add verbosity parameter diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index c18e3b8dc6..0770d32f7a 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -47,6 +47,7 @@ ;; FIXME these has to be removed (defvar comp-speed 2) +(defvar comp-verbose nil) (defvar comp-pass nil "Every pass has the right to bind what it likes here.") @@ -205,16 +206,19 @@ BODY is evaluate only if `comp-debug' is non nil." (defun comp-log (data) "Log DATA." - (if noninteractive + (if (and noninteractive + comp-verbose) (if (atom data) (message "%s" data) (mapc (lambda (x) (message "%s"(prin1-to-string x))) data)) (comp-within-log-buff - (mapc (lambda (x) - (insert (prin1-to-string x) "\n")) - data)))) + (if (and data (atom data)) + (insert data) + (mapc (lambda (x) + (insert (prin1-to-string x) "\n")) + data))))) (defun comp-log-func (func) "Log function FUNC." commit b32900474fb5e4afdfd0c0015f6b08d58b5e7847 Author: Andrea Corallo Date: Sun Sep 8 20:54:41 2019 +0200 rework log mechanism to work non interactively too diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 644bd2b8d1..c18e3b8dc6 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -203,30 +203,27 @@ BODY is evaluate only if `comp-debug' is non nil." (goto-char (point-max)) ,@body)))) - -(defun comp-log (string) - "Log a STRING into the log-buffer." - (comp-within-log-buff - (cond (noninteractive - (message " %s" string)) - (t - (insert string "\n"))))) - -(defun comp-prettyprint (data) - "Nicely print DATA in the current buffer." - (mapc (lambda (x) - (insert (prin1-to-string x) "\n")) - data)) +(defun comp-log (data) + "Log DATA." + (if noninteractive + (if (atom data) + (message "%s" data) + (mapc (lambda (x) + (message "%s"(prin1-to-string x))) + data)) + (comp-within-log-buff + (mapc (lambda (x) + (insert (prin1-to-string x) "\n")) + data)))) (defun comp-log-func (func) - "Pretty print function FUNC in the log-buffer." - (comp-within-log-buff - (insert (format "\n\n Function: %s" (comp-func-symbol-name func))) - (cl-loop for block-name being each hash-keys of (comp-func-blocks func) - using (hash-value bb) - do (progn - (insert (concat "\n<" (symbol-name block-name) ">")) - (comp-prettyprint (comp-block-insns bb)))))) + "Log function FUNC." + (comp-log (format "\n\n Function: %s" (comp-func-symbol-name func))) + (cl-loop for block-name being each hash-keys of (comp-func-blocks func) + using (hash-value bb) + do (progn + (comp-log (concat "\n<" (symbol-name block-name) ">")) + (comp-log (comp-block-insns bb))))) ;;; spill-lap pass specific code. @@ -276,8 +273,7 @@ Put PREFIX in front of it." (error "Can't native compile an already bytecompiled function")) (setf (comp-func-byte-func func) (byte-compile (comp-func-symbol-name func))) - (comp-within-log-buff - (comp-prettyprint byte-to-native-last-lap)) + (comp-log byte-to-native-last-lap) (let ((lambda-list (aref (comp-func-byte-func func) 0))) (setf (comp-func-args func) (comp-decrypt-lambda-list lambda-list))) @@ -304,8 +300,7 @@ Put PREFIX in front of it." :args (comp-decrypt-lambda-list lambda-list) :lap lap :frame-size (aref bytecode 3)) - do (comp-within-log-buff - (comp-prettyprint lap)) + do (comp-log lap) collect func)) (defun comp-spill-lap (input) commit a8517ba3ceb21f3fb5c452226d5ca6a3981ae852 Author: Andrea Corallo Date: Sun Sep 8 20:39:34 2019 +0200 add sanity check into compile_function diff --git a/src/comp.c b/src/comp.c index c2bd135495..8422c7d343 100644 --- a/src/comp.c +++ b/src/comp.c @@ -2698,6 +2698,7 @@ compile_function (Lisp_Object func) Lisp_Object block_name = HASH_KEY (ht, i); Lisp_Object block = HASH_VALUE (ht, i); Lisp_Object insns = FUNCALL1 (comp-block-insns, block); + eassert (!NILP (block) && !NILP (insns)); comp.block = retrive_block (block_name); while (CONSP (insns)) commit a70e54f6f7a6e711bcc49fce4e117d9c3e9d71a1 Author: Andrea Corallo Date: Sun Sep 8 20:16:09 2019 +0200 some error handling in compile_function diff --git a/src/comp.c b/src/comp.c index b6733522a1..c2bd135495 100644 --- a/src/comp.c +++ b/src/comp.c @@ -2626,7 +2626,7 @@ define_bool_to_lisp_obj (void) static void compile_function (Lisp_Object func) { - char *c_name = (char *) SDATA (FUNCALL1 (comp-func-c-func-name, func)); + char *c_name = SSDATA (FUNCALL1 (comp-func-c-func-name, func)); Lisp_Object args = FUNCALL1 (comp-func-args, func); EMACS_INT frame_size = XFIXNUM (FUNCALL1 (comp-func-frame-size, func)); bool ncall = (FUNCALL1 (comp-nargs-p, args)); @@ -2707,6 +2707,11 @@ compile_function (Lisp_Object func) insns = XCDR (insns); } } + const char *err = gcc_jit_context_get_first_error (comp.ctxt); + if (err) + error ("Failing to compile function %s with error:%s", + SSDATA (SYMBOL_NAME (FUNCALL1 (comp-func-symbol-name, func))), + err); } commit a2b9d58b2e2f56679b33995e2d86b0624c0b1905 Author: Andrea Corallo Date: Sun Sep 8 20:08:58 2019 +0200 nit into comp-log diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 4f407eabc0..644bd2b8d1 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -210,7 +210,7 @@ BODY is evaluate only if `comp-debug' is non nil." (cond (noninteractive (message " %s" string)) (t - (insert (format "%s\n" string)))))) + (insert string "\n"))))) (defun comp-prettyprint (data) "Nicely print DATA in the current buffer." commit 5adfe6520b5a3ff2e3bacc603487c4f12e54dfc7 Author: Andrea Corallo Date: Sun Sep 8 19:56:37 2019 +0200 fix pretty printing in native compilation buffer diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 702e10df8d..4f407eabc0 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -203,6 +203,7 @@ BODY is evaluate only if `comp-debug' is non nil." (goto-char (point-max)) ,@body)))) + (defun comp-log (string) "Log a STRING into the log-buffer." (comp-within-log-buff @@ -211,6 +212,12 @@ BODY is evaluate only if `comp-debug' is non nil." (t (insert (format "%s\n" string)))))) +(defun comp-prettyprint (data) + "Nicely print DATA in the current buffer." + (mapc (lambda (x) + (insert (prin1-to-string x) "\n")) + data)) + (defun comp-log-func (func) "Pretty print function FUNC in the log-buffer." (comp-within-log-buff @@ -219,7 +226,7 @@ BODY is evaluate only if `comp-debug' is non nil." using (hash-value bb) do (progn (insert (concat "\n<" (symbol-name block-name) ">")) - (cl-prettyprint (comp-block-insns bb)))))) + (comp-prettyprint (comp-block-insns bb)))))) ;;; spill-lap pass specific code. @@ -270,7 +277,7 @@ Put PREFIX in front of it." (setf (comp-func-byte-func func) (byte-compile (comp-func-symbol-name func))) (comp-within-log-buff - (cl-prettyprint byte-to-native-last-lap)) + (comp-prettyprint byte-to-native-last-lap)) (let ((lambda-list (aref (comp-func-byte-func func) 0))) (setf (comp-func-args func) (comp-decrypt-lambda-list lambda-list))) @@ -298,7 +305,7 @@ Put PREFIX in front of it." :lap lap :frame-size (aref bytecode 3)) do (comp-within-log-buff - (cl-prettyprint lap)) + (comp-prettyprint lap)) collect func)) (defun comp-spill-lap (input) commit ef6c633b9d5532d8888535a43ec8abc7de0a34f7 Author: Andrea Corallo Date: Sun Sep 8 18:48:29 2019 +0200 add assertion for missing op support diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 12c8ca6369..702e10df8d 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -817,7 +817,7 @@ the annotation emission." (byte-stack-set (comp-with-sp (1+ (comp-sp)) (comp-copy-slot (comp-sp) (- (comp-sp) arg)))) - (byte-stack-set2) ;; TODO + (byte-stack-set2 (cl-assert nil)) ;; TODO (byte-discardN (comp-stack-adjust (- arg))) (byte-switch commit 1b9b19ebf911a959948de513afe3f639e23f346a Author: Andrea Corallo Date: Sun Sep 8 18:48:14 2019 +0200 fix missing specbind import diff --git a/src/comp.c b/src/comp.c index 2b6f8bf053..b6733522a1 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1676,6 +1676,9 @@ declare_runtime_imported_funcs (void) args[0] = comp.lisp_obj_type; ADD_IMPORTED ("helper_unwind_protect", comp.void_type, 1, args); + args[0] = args[1] = comp.lisp_obj_type; + ADD_IMPORTED ("specbind", comp.void_type, 2, args); + #undef ADD_IMPORTED return field_list; @@ -3149,6 +3152,9 @@ load_comp_unit (dynlib_handle_ptr handle) } else if (!strcmp (f_str, "helper_unwind_protect")) { f_relocs[i] = (void *) helper_unwind_protect; + } else if (!strcmp (f_str, "specbind")) + { + f_relocs[i] = (void *) specbind; } else { error ("Unexpected function relocation %s", f_str); commit 4c6272373d4e5a6fbb8668f4980bbafbdc28405e Author: Andrea Corallo Date: Sun Sep 8 17:13:48 2019 +0200 add defconst support diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index c5c36e9eda..12c8ca6369 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -283,9 +283,9 @@ Put PREFIX in front of it." (byte-compile-file filename) (setf (comp-ctxt-top-level-defvars comp-ctxt) (reverse (mapcar (lambda (x) - (if (eq (car x) 'defvar) - (cdr x) - (cl-assert nil))) + (ecase (car x) + ('defvar (cdr x)) + ('defconst (cdr x)))) byte-to-native-top-level-forms))) (cl-loop for (name lap bytecode) in byte-to-native-output for lambda-list = (aref bytecode 0) commit f74ab3e9ef7a5a63efdb4a7e0bca0c9cc71bf575 Author: Andrea Corallo Date: Sun Sep 8 17:04:06 2019 +0200 get right dependency during top level form evaluantion diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 811e03a5ed..c5c36e9eda 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -282,11 +282,11 @@ Put PREFIX in front of it." "Byte compile FILENAME spilling data from the byte compiler." (byte-compile-file filename) (setf (comp-ctxt-top-level-defvars comp-ctxt) - (mapcar (lambda (x) - (if (eq (car x) 'defvar) - (cdr x) - (cl-assert nil))) - byte-to-native-top-level-forms)) + (reverse (mapcar (lambda (x) + (if (eq (car x) 'defvar) + (cdr x) + (cl-assert nil))) + byte-to-native-top-level-forms))) (cl-loop for (name lap bytecode) in byte-to-native-output for lambda-list = (aref bytecode 0) for func = (make-comp-func :symbol-name name commit 038f46c2526fcc3643a74a6c3e9fda40691f4067 Author: Andrea Corallo Date: Sun Sep 8 16:57:40 2019 +0200 rename comp-slot-next -> comp-slot+1 diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 48e2252807..811e03a5ed 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -375,7 +375,7 @@ Restore the original value afterwards." "Current slot into the meta-stack pointed by sp." '(comp-slot-n (comp-sp))) -(defmacro comp-slot-next () +(defmacro comp-slot+1 () "Slot into the meta-stack pointed by sp + 1." '(comp-slot-n (1+ (comp-sp)))) @@ -514,7 +514,7 @@ If NEGATED non nil negate the tested condition." do (comp-with-sp sp (comp-emit-set-call (comp-call 'cons (comp-slot) - (comp-slot-next)))))) + (comp-slot+1)))))) (defun comp-new-block-sym () "Return a symbol naming the next new basic block." @@ -538,7 +538,7 @@ If NEGATED non nil negate the tested condition." (make-comp-block :sp (comp-sp)) blocks) (let ((handler-bb (comp-lap-to-limple-bb guarded-label))) - (comp-emit (list 'push-handler (comp-slot-next) + (comp-emit (list 'push-handler (comp-slot+1) handler-type handler-bb guarded-bb)) @@ -647,11 +647,11 @@ the annotation emission." (byte-varset (comp-emit (comp-call 'set_internal (make-comp-mvar :constant arg) - (comp-slot-next)))) + (comp-slot+1)))) (byte-varbind ;; Verify (comp-emit (comp-call 'specbind (make-comp-mvar :constant arg) - (comp-slot-next)))) + (comp-slot+1)))) (byte-call (comp-emit-funcall arg)) (byte-unbind @@ -746,7 +746,7 @@ the annotation emission." (byte-narrow-to-region (comp-emit-set-call (comp-call 'narrow_to_region (comp-slot) - (comp-slot-next)))) + (comp-slot+1)))) (byte-widen (comp-emit-set-call (comp-call 'widen))) (byte-end-of-line auto) @@ -754,19 +754,19 @@ the annotation emission." (byte-goto (comp-emit-jump (comp-lap-to-limple-bb (cl-third insn)))) (byte-goto-if-nil - (comp-emit-cond-jump (comp-slot-next) (make-comp-mvar :constant nil) 0 + (comp-emit-cond-jump (comp-slot+1) (make-comp-mvar :constant nil) 0 (cl-third insn) nil)) (byte-goto-if-not-nil - (comp-emit-cond-jump (comp-slot-next) (make-comp-mvar :constant nil) 0 + (comp-emit-cond-jump (comp-slot+1) (make-comp-mvar :constant nil) 0 (cl-third insn) t)) (byte-goto-if-nil-else-pop - (comp-emit-cond-jump (comp-slot-next) (make-comp-mvar :constant nil) 1 + (comp-emit-cond-jump (comp-slot+1) (make-comp-mvar :constant nil) 1 (cl-third insn) nil)) (byte-goto-if-not-nil-else-pop - (comp-emit-cond-jump (comp-slot-next) (make-comp-mvar :constant nil) 1 + (comp-emit-cond-jump (comp-slot+1) (make-comp-mvar :constant nil) 1 (cl-third insn) t)) (byte-return - (comp-emit `(return ,(comp-slot-next))) + (comp-emit `(return ,(comp-slot+1))) (comp-mark-block-closed)) (byte-discard 'pass) (byte-dup @@ -778,7 +778,7 @@ the annotation emission." (comp-call 'helper-save-restriction)) (byte-catch) ;; Obsolete (byte-unwind-protect - (comp-emit (comp-call 'helper_unwind_protect (comp-slot-next)))) + (comp-emit (comp-call 'helper_unwind_protect (comp-slot+1)))) (byte-condition-case) ;; Obsolete (byte-temp-output-buffer-setup-OBSOLETE) (byte-temp-output-buffer-show-OBSOLETE) @@ -821,7 +821,7 @@ the annotation emission." (byte-discardN (comp-stack-adjust (- arg))) (byte-switch - (comp-emit-switch (comp-slot-next) (comp-slot-n (+ 2 (comp-sp))))) + (comp-emit-switch (comp-slot+1) (comp-slot-n (+ 2 (comp-sp))))) (byte-constant (comp-emit-set-const arg)) (byte-discardN-preserve-tos commit fca675dae325a974c625893fb0ad1aa88abeab8f Author: Andrea Corallo Date: Sun Sep 8 16:31:53 2019 +0200 fix varset and add a test diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 2e98560e8f..48e2252807 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -647,7 +647,7 @@ the annotation emission." (byte-varset (comp-emit (comp-call 'set_internal (make-comp-mvar :constant arg) - (comp-slot)))) + (comp-slot-next)))) (byte-varbind ;; Verify (comp-emit (comp-call 'specbind (make-comp-mvar :constant arg) diff --git a/test/src/comp-test-funcs.el b/test/src/comp-test-funcs.el index b92716739b..4fc62482a0 100644 --- a/test/src/comp-test-funcs.el +++ b/test/src/comp-test-funcs.el @@ -50,8 +50,11 @@ (defun comp-tests-cons-cdr-f (x) (cdr (cons 'foo x))) -(defun comp-tests-varset-f () +(defun comp-tests-varset0-f () (setq comp-tests-var1 55)) +(defun comp-tests-varset1-f () + (setq comp-tests-var1 66) + 4) (defun comp-tests-length-f () (length '(1 2 3))) diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 47ae7899c6..331e1cfed1 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -71,8 +71,11 @@ (ert-deftest comp-tests-varset () "Testing varset." - (comp-tests-varset-f) - (should (= comp-tests-var1 55))) + (comp-tests-varset0-f) + (should (= comp-tests-var1 55)) + + (should (= (comp-tests-varset1-f) 4)) + (should (= comp-tests-var1 66))) (ert-deftest comp-tests-length () "Testing length." commit 59a428ed6ccd7ee41e847b1d63889845fae7ebd5 Author: Andrea Corallo Date: Sun Sep 8 15:55:23 2019 +0200 fix single function compilation diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index f82993956b..77cd408ce9 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -565,7 +565,7 @@ Each element is (INDEX . VALUE)") ;; These are use by comp.el to spill data out of here (defvar byte-native-compiling nil) -(defvar byte-last-lap nil) +(defvar byte-to-native-last-lap nil) (defvar byte-to-native-output nil) (defvar byte-to-native-top-level-forms nil) @@ -2274,7 +2274,7 @@ list that represents a doc string reference. `defvaralias', `autoload' and `custom-declare-variable' need that." (when byte-native-compiling ;; Spill output for the native compiler here - (push (list name byte-last-lap (apply #'vector form)) byte-to-native-output)) + (push (list name byte-to-native-last-lap (apply #'vector form)) byte-to-native-output)) ;; We need to examine byte-compile-dynamic-docstrings ;; in the input buffer (now current), not in the output buffer. (let ((dynamic-docstrings byte-compile-dynamic-docstrings)) @@ -3129,7 +3129,7 @@ for symbols generated by the byte compiler itself." byte-compile-vector byte-compile-maxdepth))) (when byte-native-compiling ;; Spill output for the native compiler here - (setq byte-last-lap byte-compile-output)) + (setq byte-to-native-last-lap byte-compile-output)) out)) ;; it's a trivial function ((cdr body) (cons 'progn (nreverse body))) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 39f00c5792..2e98560e8f 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -270,11 +270,11 @@ Put PREFIX in front of it." (setf (comp-func-byte-func func) (byte-compile (comp-func-symbol-name func))) (comp-within-log-buff - (cl-prettyprint byte-to-native-lap-output)) + (cl-prettyprint byte-to-native-last-lap)) (let ((lambda-list (aref (comp-func-byte-func func) 0))) (setf (comp-func-args func) (comp-decrypt-lambda-list lambda-list))) - (setf (comp-func-lap func) (car byte-to-native-lap-output)) + (setf (comp-func-lap func) byte-to-native-last-lap) (setf (comp-func-frame-size func) (aref (comp-func-byte-func func) 3)) func)) @@ -306,7 +306,7 @@ Put PREFIX in front of it." If INPUT is a symbol this is the function-name to be compiled. If INPUT is a string this is the file path to be compiled." (let ((byte-native-compiling t) - (byte-last-lap nil) + (byte-to-native-last-lap nil) (byte-to-native-output ()) (byte-to-native-top-level-forms ())) (cl-typecase input commit 314f9fcf6cb8a6f513022a40ee384ff0e4ca513a Author: Andrea Corallo Date: Sun Sep 8 15:42:52 2019 +0200 uncomment back all tests diff --git a/test/src/comp-test-funcs.el b/test/src/comp-test-funcs.el index 609147e7e2..b92716739b 100644 --- a/test/src/comp-test-funcs.el +++ b/test/src/comp-test-funcs.el @@ -89,10 +89,10 @@ (defun comp-tests-ffuncall-apply-many-f (x) (apply #'list x)) -;; (defun comp-tests-ffuncall-lambda-f (x) -;; (let ((fun (lambda (x) -;; (1+ x)))) -;; (funcall fun x))) +(defun comp-tests-ffuncall-lambda-f (x) + (let ((fun (lambda (x) + (1+ x)))) + (funcall fun x))) (defun comp-tests-jump-table-1-f (x) (pcase x @@ -211,10 +211,10 @@ (defun comp-tests-throw-f (x) (throw 'foo x)) -;; (defun comp-tests-buff0-f () -;; (with-temp-buffer -;; (insert "foo") -;; (buffer-string))) +(defun comp-tests-buff0-f () + (with-temp-buffer + (insert "foo") + (buffer-string))) (defun comp-tests-lambda-return-f () (lambda (x) (1+ x))) @@ -319,15 +319,15 @@ (defun comp-test-opt (a &optional b) (cons a b)) -;; ;; Test for unwind-protect. -;; (defvar comp-test-up-val nil) -;; (defun comp-test-unwind-protect (fun) -;; (setq comp-test-up-val nil) -;; (unwind-protect -;; (progn -;; (setq comp-test-up-val 23) -;; (funcall fun) -;; (setq comp-test-up-val 24)) -;; (setq comp-test-up-val 999))) +;; Test for unwind-protect. +(defvar comp-test-up-val nil) +(defun comp-test-unwind-protect (fun) + (setq comp-test-up-val nil) + (unwind-protect + (progn + (setq comp-test-up-val 23) + (funcall fun) + (setq comp-test-up-val 24)) + (setq comp-test-up-val 999))) ;;; comp-test-funcs.el ends here commit 555450c7b1b1c02126bd9fc86486090fe2b829b5 Author: Andrea Corallo Date: Sun Sep 8 15:40:56 2019 +0200 fix lambda handling and add a test for that diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 3d4b76b988..f82993956b 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -565,9 +565,8 @@ Each element is (INDEX . VALUE)") ;; These are use by comp.el to spill data out of here (defvar byte-native-compiling nil) -(defvar byte-to-native-names nil) -(defvar byte-to-native-lap-output nil) -(defvar byte-to-native-bytecode-output nil) +(defvar byte-last-lap nil) +(defvar byte-to-native-output nil) (defvar byte-to-native-top-level-forms nil) @@ -2274,9 +2273,8 @@ QUOTED says that we have to put a quote before the list that represents a doc string reference. `defvaralias', `autoload' and `custom-declare-variable' need that." (when byte-native-compiling - ;; Spill output for the native compiler here - (push name byte-to-native-names) - (push (apply #'vector form) byte-to-native-bytecode-output)) + ;; Spill output for the native compiler here + (push (list name byte-last-lap (apply #'vector form)) byte-to-native-output)) ;; We need to examine byte-compile-dynamic-docstrings ;; in the input buffer (now current), not in the output buffer. (let ((dynamic-docstrings byte-compile-dynamic-docstrings)) @@ -3131,7 +3129,7 @@ for symbols generated by the byte compiler itself." byte-compile-vector byte-compile-maxdepth))) (when byte-native-compiling ;; Spill output for the native compiler here - (push byte-compile-output byte-to-native-lap-output)) + (setq byte-last-lap byte-compile-output)) out)) ;; it's a trivial function ((cdr body) (cons 'progn (nreverse body))) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 3ea500416d..39f00c5792 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -281,23 +281,18 @@ Put PREFIX in front of it." (defun comp-spill-lap-functions-file (filename) "Byte compile FILENAME spilling data from the byte compiler." (byte-compile-file filename) - (cl-assert (= (length byte-to-native-names) - (length byte-to-native-lap-output) - (length byte-to-native-bytecode-output))) (setf (comp-ctxt-top-level-defvars comp-ctxt) (mapcar (lambda (x) (if (eq (car x) 'defvar) (cdr x) (cl-assert nil))) byte-to-native-top-level-forms)) - (cl-loop for function-name in byte-to-native-names - for lap in byte-to-native-lap-output - for bytecode in byte-to-native-bytecode-output + (cl-loop for (name lap bytecode) in byte-to-native-output for lambda-list = (aref bytecode 0) - for func = (make-comp-func :symbol-name function-name + for func = (make-comp-func :symbol-name name :byte-func bytecode :c-func-name (comp-c-func-name - function-name + name "F") :args (comp-decrypt-lambda-list lambda-list) :lap lap @@ -311,9 +306,8 @@ Put PREFIX in front of it." If INPUT is a symbol this is the function-name to be compiled. If INPUT is a string this is the file path to be compiled." (let ((byte-native-compiling t) - (byte-to-native-names ()) - (byte-to-native-lap-output ()) - (byte-to-native-bytecode-output ()) + (byte-last-lap nil) + (byte-to-native-output ()) (byte-to-native-top-level-forms ())) (cl-typecase input (symbol (list (comp-spill-lap-function input))) diff --git a/test/src/comp-test-funcs.el b/test/src/comp-test-funcs.el index 6d7311088a..609147e7e2 100644 --- a/test/src/comp-test-funcs.el +++ b/test/src/comp-test-funcs.el @@ -216,6 +216,9 @@ ;; (insert "foo") ;; (buffer-string))) +(defun comp-tests-lambda-return-f () + (lambda (x) (1+ x))) + ;;;;;;;;;;;;;;;;;;;; ;; Tromey's tests ;; ;;;;;;;;;;;;;;;;;;;; diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index ea1aab6e4c..47ae7899c6 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -256,6 +256,9 @@ (ert-deftest comp-tests-buffer () (should (string= (comp-tests-buff0-f) "foo"))) +(ert-deftest comp-tests-lambda-return () + (should (= (funcall (comp-tests-lambda-return-f) 3) 4))) + ;;;;;;;;;;;;;;;;;;;; ;; Tromey's tests ;; ;;;;;;;;;;;;;;;;;;;; commit 06ad74581385cd1930a073b2fda314230b254608 Author: Andrea Corallo Date: Sun Sep 8 10:11:36 2019 +0200 rename HAVE_LIBGCCJIT -> HAVE_NATIVE_COMP diff --git a/configure.ac b/configure.ac index a36a2f3242..0cfd80bb2e 100644 --- a/configure.ac +++ b/configure.ac @@ -3672,15 +3672,15 @@ fi AC_SUBST(LIBZ) ### Emacs Lisp native compiler support -HAVE_LIBGCCJIT=no +HAVE_NATIVE_COMP=no LIBGCCJIT_LIB= COMP_OBJ= if test "${with_nativecomp}" != "no"; then - AC_CHECK_LIB(gccjit, gcc_jit_context_acquire, HAVE_LIBGCCJIT=yes, , -lgccjit) - if test "${HAVE_LIBGCCJIT}" = "yes"; then + AC_CHECK_LIB(gccjit, gcc_jit_context_acquire, HAVE_NATIVE_COMP=yes, , -lgccjit) + if test "${HAVE_NATIVE_COMP}" = "yes"; then LIBGCCJIT_LIB="-lgccjit -ldl" COMP_OBJ="dynlib.o comp.o" - AC_DEFINE(HAVE_LIBGCCJIT, 1, [Define to 1 if you have the libgccjit library (-lgccjit).]) + AC_DEFINE(HAVE_NATIVE_COMP, 1, [Define to 1 if you have the libgccjit library (-lgccjit).]) AC_DEFINE_UNQUOTED(NATIVE_ELISP_SUFFIX, ".eln", [System extension for native compiled elisp]) fi diff --git a/src/comp.c b/src/comp.c index 00e1560199..2b6f8bf053 100644 --- a/src/comp.c +++ b/src/comp.c @@ -20,7 +20,7 @@ along with GNU Emacs. If not, see . */ #include -#ifdef HAVE_LIBGCCJIT +#ifdef HAVE_NATIVE_COMP #include #include @@ -3283,4 +3283,4 @@ syms_of_comp (void) comp_speed = DEFAULT_SPEED; } -#endif /* HAVE_LIBGCCJIT */ +#endif /* HAVE_NATIVE_COMP */ diff --git a/src/emacs.c b/src/emacs.c index c59a70988b..90ab7ac1e8 100644 --- a/src/emacs.c +++ b/src/emacs.c @@ -1598,7 +1598,7 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem init_json (); #endif -#ifdef HAVE_LIBGCCJIT +#ifdef HAVE_NATIVE_COMP if (!initialized) syms_of_comp (); #endif diff --git a/src/lread.c b/src/lread.c index b10743f980..f1b17edd01 100644 --- a/src/lread.c +++ b/src/lread.c @@ -1281,7 +1281,7 @@ Return t if the file exists and loads successfully. */) bool is_module = false; #endif -#ifdef HAVE_LIBGCCJIT +#ifdef HAVE_NATIVE_COMP bool is_native_elisp = suffix_p (found, NATIVE_ELISP_SUFFIX); #else bool is_native_elisp = false; @@ -1486,7 +1486,7 @@ Return t if the file exists and loads successfully. */) } else if (is_native_elisp) { -#ifdef HAVE_LIBGCCJIT +#ifdef HAVE_NATIVE_COMP specbind (Qcurrent_load_list, Qnil); LOADHIST_ATTACH (found); Fnative_elisp_load (found); @@ -4896,7 +4896,7 @@ to the specified file name if a suffix is allowed or required. */); Fcons (build_pure_c_string (MODULES_SECONDARY_SUFFIX), Vload_suffixes); #endif #endif -#ifdef HAVE_LIBGCCJIT +#ifdef HAVE_NATIVE_COMP Vload_suffixes = Fcons (build_pure_c_string (NATIVE_ELISP_SUFFIX), Vload_suffixes); #endif commit 17259826f263f87d45eb98c8effe0ba7ee774f5d Author: Andrea Corallo Date: Sun Sep 8 09:40:42 2019 +0200 fix build system for native compiler option diff --git a/configure.ac b/configure.ac index 6213051a60..a36a2f3242 100644 --- a/configure.ac +++ b/configure.ac @@ -3671,18 +3671,22 @@ if test "${HAVE_ZLIB}" = "yes"; then fi AC_SUBST(LIBZ) +### Emacs Lisp native compiler support HAVE_LIBGCCJIT=no LIBGCCJIT_LIB= +COMP_OBJ= if test "${with_nativecomp}" != "no"; then AC_CHECK_LIB(gccjit, gcc_jit_context_acquire, HAVE_LIBGCCJIT=yes, , -lgccjit) if test "${HAVE_LIBGCCJIT}" = "yes"; then - LIBGCCJIT_LIB=-lgccjit - AC_DEFINE([HAVE_LIBGCCJIT], 1, [Define to 1 if you have the libgccjit library (-lgccjit).]) + LIBGCCJIT_LIB="-lgccjit -ldl" + COMP_OBJ="dynlib.o comp.o" + AC_DEFINE(HAVE_LIBGCCJIT, 1, [Define to 1 if you have the libgccjit library (-lgccjit).]) AC_DEFINE_UNQUOTED(NATIVE_ELISP_SUFFIX, ".eln", [System extension for native compiled elisp]) fi fi -AC_SUBST([LIBGCCJIT_LIB]) +AC_SUBST(LIBGCCJIT_LIB) +AC_SUBST(COMP_OBJ) ### Dynamic modules support LIBMODULES= diff --git a/src/Makefile.in b/src/Makefile.in index 5e0e36d8b4..6c65275d6d 100644 --- a/src/Makefile.in +++ b/src/Makefile.in @@ -327,6 +327,8 @@ GMP_LIB = @GMP_LIB@ GMP_OBJ = @GMP_OBJ@ LIBGCCJIT = @LIBGCCJIT_LIB@ +## dynlib.o comp.o if native compiler is enabled, else empty +COMP_OBJ = @COMP_OBJ@ RUN_TEMACS = ./temacs @@ -416,7 +418,7 @@ base_obj = dispnew.o frame.o scroll.o xdisp.o menu.o $(XMENU_OBJ) window.o \ cmds.o casetab.o casefiddle.o indent.o search.o regex-emacs.o undo.o \ alloc.o pdumper.o data.o doc.o editfns.o callint.o \ eval.o floatfns.o fns.o font.o print.o lread.o $(MODULES_OBJ) \ - syntax.o $(UNEXEC_OBJ) bytecode.o comp.o \ + syntax.o $(UNEXEC_OBJ) bytecode.o $(COMP_OBJ) \ process.o gnutls.o callproc.o \ region-cache.o sound.o timefns.o atimer.o \ doprnt.o intervals.o textprop.o composite.o xml.o lcms.o $(NOTIFY_OBJ) \ commit 4814c6b1184a2b3fe673c5389ce0a8d2c67aec09 Author: Andrea Corallo Date: Sat Sep 7 16:35:07 2019 +0200 initial top level support (defvar working) diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index ec7b036a67..3d4b76b988 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -568,6 +568,7 @@ Each element is (INDEX . VALUE)") (defvar byte-to-native-names nil) (defvar byte-to-native-lap-output nil) (defvar byte-to-native-bytecode-output nil) +(defvar byte-to-native-top-level-forms nil) ;;; The byte codes; this information is duplicated in bytecomp.c @@ -2491,6 +2492,9 @@ list that represents a doc string reference. (setq form (copy-sequence form)) (setcar (cdr (cdr form)) (byte-compile-top-level (nth 2 form) nil 'file)))) + (when byte-native-compiling + ;; Spill output for the native compiler here + (push form byte-to-native-top-level-forms)) form)) (put 'define-abbrev-table 'byte-hunk-handler diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 1a426560ba..3ea500416d 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -80,8 +80,10 @@ (cl-defstruct comp-ctxt "Lisp side of the compiler context." - (output nil :'string + (output nil :type 'string :documentation "Target output filename for the compilation.") + (top-level-defvars nil :type list + :documentation "List of top level form to be compiled.") (funcs () :type list :documentation "Exported functions list.") (funcs-h (make-hash-table) :type hash-table @@ -160,7 +162,7 @@ LIMPLE basic block.") :documentation "When non nil is used for type propagation.")) (cl-defstruct (comp-limplify (:copier nil)) - "Support structure used during limplification." + "Support structure used during function limplification." (sp 0 :type fixnum :documentation "Current stack pointer while walking LAP.") (frame nil :type vector @@ -282,6 +284,12 @@ Put PREFIX in front of it." (cl-assert (= (length byte-to-native-names) (length byte-to-native-lap-output) (length byte-to-native-bytecode-output))) + (setf (comp-ctxt-top-level-defvars comp-ctxt) + (mapcar (lambda (x) + (if (eq (car x) 'defvar) + (cdr x) + (cl-assert nil))) + byte-to-native-top-level-forms)) (cl-loop for function-name in byte-to-native-names for lap in byte-to-native-lap-output for bytecode in byte-to-native-bytecode-output @@ -305,7 +313,8 @@ If INPUT is a string this is the file path to be compiled." (let ((byte-native-compiling t) (byte-to-native-names ()) (byte-to-native-lap-output ()) - (byte-to-native-bytecode-output ())) + (byte-to-native-bytecode-output ()) + (byte-to-native-top-level-forms ())) (cl-typecase input (symbol (list (comp-spill-lap-function input))) (string (comp-spill-lap-functions-file input))))) @@ -848,38 +857,64 @@ the annotation emission." (comp-emit-block 'entry_rest_args) (comp-emit `(set-rest-args-to-local ,nonrest))) +(defun comp-limplify-finalize-function (func) + "Reverse insns into all basic blocks of FUNC." + (cl-loop for bb being the hash-value in (comp-func-blocks func) + do (setf (comp-block-insns bb) + (nreverse (comp-block-insns bb)))) + (comp-log-func func) + func) + +(defun comp-limplify-top-level () + "Create a limple function doing the business for top level forms. +This will be called at runtime." + (let* ((func (make-comp-func :symbol-name 'top-level-run + :c-func-name "top_level_run" + :args (make-comp-args :min 0 :max 0) + :frame-size 0)) + (comp-func func) + (comp-pass (make-comp-limplify + :sp -1 + :frame (comp-new-frame 0))) + (comp-block ())) + (comp-emit-block 'entry) + (comp-emit-annotation "Top level") + (cl-loop for args in (comp-ctxt-top-level-defvars comp-ctxt) + do (comp-emit (comp-call 'defvar (make-comp-mvar :constant args)))) + (comp-emit `(return ,(make-comp-mvar :constant nil))) + (comp-limplify-finalize-function func))) + +(defun comp-limplify-function (func) + "Limplify a single function FUNC." + (let* ((frame-size (comp-func-frame-size func)) + (comp-func func) + (comp-pass (make-comp-limplify + :sp -1 + :frame (comp-new-frame frame-size))) + (args (comp-func-args func)) + (args-min (comp-args-base-min args)) + (comp-block ())) + ;; Prologue + (comp-emit-block 'entry) + (comp-emit-annotation (concat "Lisp function: " + (symbol-name (comp-func-symbol-name func)))) + (if (comp-args-p args) + (cl-loop for i below (comp-args-max args) + do (cl-incf (comp-sp)) + do (comp-emit `(set-par-to-local ,(comp-slot) ,i))) + (let ((nonrest (comp-nargs-nonrest args))) + (comp-emit-narg-prologue args-min nonrest) + (cl-incf (comp-sp) (1+ nonrest)))) + ;; Body + (comp-emit-block 'bb_1) + (mapc #'comp-limplify-lap-inst (comp-func-lap func)) + (comp-limplify-finalize-function func))) + (defun comp-limplify (funcs) - "Given FUNCS compute their LIMPLE ir." - (mapcar (lambda (func) - (let* ((frame-size (comp-func-frame-size func)) - (comp-func func) - (comp-pass (make-comp-limplify - :sp -1 - :frame (comp-new-frame frame-size))) - (args (comp-func-args func)) - (args-min (comp-args-base-min args)) - (comp-block ())) - ;; Prologue - (comp-emit-block 'entry) - (comp-emit-annotation (concat "Lisp function: " - (symbol-name (comp-func-symbol-name func)))) - (if (comp-args-p args) - (cl-loop for i below (comp-args-max args) - do (cl-incf (comp-sp)) - do (comp-emit `(set-par-to-local ,(comp-slot) ,i))) - (let ((nonrest (comp-nargs-nonrest args))) - (comp-emit-narg-prologue args-min nonrest) - (cl-incf (comp-sp) (1+ nonrest)))) - ;; Body - (comp-emit-block 'bb_1) - (mapc #'comp-limplify-lap-inst (comp-func-lap func)) - ;; Reverse insns into all basic blocks. - (cl-loop for bb being the hash-value in (comp-func-blocks func) - do (setf (comp-block-insns bb) - (nreverse (comp-block-insns bb)))) - (comp-log-func func) - func)) - funcs)) + "Compute the LIMPLE ir for FUNCS. +Top level forms for the current context are rendered too." + (cons (comp-limplify-top-level) + (mapcar #'comp-limplify-function funcs))) ;;; Final pass specific code. diff --git a/src/comp.c b/src/comp.c index 07c779369c..00e1560199 100644 --- a/src/comp.c +++ b/src/comp.c @@ -304,6 +304,12 @@ declare_imported_func (Lisp_Object subr_sym, gcc_jit_type *ret_type, types[0] = comp.ptrdiff_type; types[1] = comp.lisp_obj_ptr_type; } + if (nargs == UNEVALLED) + { + nargs = 1; + types = alloca (nargs * sizeof (* types)); + types[0] = comp.lisp_obj_type; + } else if (!types) { types = alloca (nargs * sizeof (* types)); @@ -1718,7 +1724,7 @@ emit_ctxt_code (void) FOR_EACH_TAIL (f_runtime) { Lisp_Object el = XCAR (f_runtime); - fields[n_frelocs++] = xmint_pointer( XCDR (el)); + fields[n_frelocs++] = xmint_pointer (XCDR (el)); f_reloc_list = Fcons (XCAR (el), f_reloc_list); } @@ -1732,10 +1738,12 @@ emit_ctxt_code (void) Lisp_Object maxarg = XCDR (Fsubr_arity (subr)); gcc_jit_field *field = declare_imported_func (subr_sym, comp.lisp_obj_type, - FIXNUMP (maxarg) ? XFIXNUM (maxarg) : MANY, NULL); + FIXNUMP (maxarg) ? XFIXNUM (maxarg) : + EQ (maxarg, Qmany) ? MANY : UNEVALLED, + NULL); fields [n_frelocs++] = field; f_reloc_list = Fcons (subr_sym, f_reloc_list); - } + } } Lisp_Object f_reloc_vec = make_vector (n_frelocs, Qnil); @@ -3173,6 +3181,10 @@ load_comp_unit (dynlib_handle_ptr handle) func_list = XCDR (func_list); } + /* Finally execute top level forms. */ + void (*top_level_run)(void) = dynlib_sym (handle, "top_level_run"); + top_level_run (); + return 0; } commit ac47ef773e0cf734a3e3e4237aca50704a0a68be Author: Andrea Corallo Date: Sat Sep 7 11:55:20 2019 +0200 test separate compile unit diff --git a/test/src/comp-test-funcs.el b/test/src/comp-test-funcs.el new file mode 100644 index 0000000000..6d7311088a --- /dev/null +++ b/test/src/comp-test-funcs.el @@ -0,0 +1,330 @@ +;;; comp-test-funcs.el --- compilation unit tested by comp-tests.el -*- lexical-binding: t; -*- + +;; Copyright (C) 2019 Free Software Foundation, Inc. + +;; Author: Andrea Corallo + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;;; Code: + +(defvar comp-tests-var1 3) + +(defun comp-tests-varref-f () + comp-tests-var1) + +(defun comp-tests-list-f () + (list 1 2 3)) +(defun comp-tests-list2-f (a b c) + (list a b c)) +(defun comp-tests-car-f (x) + ;; Bcar + (car x)) +(defun comp-tests-cdr-f (x) + ;; Bcdr + (cdr x)) +(defun comp-tests-car-safe-f (x) + ;; Bcar_safe + (car-safe x)) +(defun comp-tests-cdr-safe-f (x) + ;; Bcdr_safe + (cdr-safe x)) + +(defun comp-tests-cons-car-f () + (car (cons 1 2))) +(defun comp-tests-cons-cdr-f (x) + (cdr (cons 'foo x))) + +(defun comp-tests-varset-f () + (setq comp-tests-var1 55)) + +(defun comp-tests-length-f () + (length '(1 2 3))) + +(defun comp-tests-aref-aset-f () + (let ((vec [1 2 3])) + (aset vec 2 100) + (aref vec 2))) + +(defvar comp-tests-var2 3) +(defun comp-tests-symbol-value-f () + (symbol-value 'comp-tests-var2)) + +(defun comp-tests-concat-f (x) + (concat "a" "b" "c" "d" + (concat "a" "b" "c" (concat "a" "b" (concat "foo" x))))) + +(defun comp-tests-ffuncall-callee-f (x y z) + (list x y z)) + +(defun comp-tests-ffuncall-callee-optional-f (a b &optional c d) + (list a b c d)) + +(defun comp-tests-ffuncall-callee-rest-f (a b &rest c) + (list a b c)) + +(defun comp-tests-ffuncall-native-f () + "Call a primitive with no dedicate op." + (make-vector 1 nil)) + +(defun comp-tests-ffuncall-native-rest-f () + "Call a primitive with no dedicate op with &rest." + (vector 1 2 3)) + +(defun comp-tests-ffuncall-apply-many-f (x) + (apply #'list x)) + +;; (defun comp-tests-ffuncall-lambda-f (x) +;; (let ((fun (lambda (x) +;; (1+ x)))) +;; (funcall fun x))) + +(defun comp-tests-jump-table-1-f (x) + (pcase x + ('x 'a) + ('y 'b) + (_ 'c))) + +(defun comp-tests-conditionals-1-f (x) + ;; Generate goto-if-nil + (if x 1 2)) +(defun comp-tests-conditionals-2-f (x) + ;; Generate goto-if-nil-else-pop + (when x + 1340)) + +(defun comp-tests-fixnum-1-minus-f (x) + ;; Bsub1 + (1- x)) +(defun comp-tests-fixnum-1-plus-f (x) + ;; Badd1 + (1+ x)) +(defun comp-tests-fixnum-minus-f (x) + ;; Bnegate + (- x)) + +(defun comp-tests-eqlsign-f (x y) + ;; Beqlsign + (= x y)) +(defun comp-tests-gtr-f (x y) + ;; Bgtr + (> x y)) +(defun comp-tests-lss-f (x y) + ;; Blss + (< x y)) +(defun comp-tests-les-f (x y) + ;; Bleq + (<= x y)) +(defun comp-tests-geq-f (x y) + ;; Bgeq + (>= x y)) + +(defun comp-tests-setcar-f (x y) + (setcar x y) + x) +(defun comp-tests-setcdr-f (x y) + (setcdr x y) + x) + +(defun comp-bubble-sort-f (list) + (let ((i (length list))) + (while (> i 1) + (let ((b list)) + (while (cdr b) + (when (< (cadr b) (car b)) + (setcar b (prog1 (cadr b) + (setcdr b (cons (car b) (cddr b)))))) + (setq b (cdr b)))) + (setq i (1- i))) + list)) + +(defun comp-tests-consp-f (x) + ;; Bconsp + (consp x)) +(defun comp-tests-setcar2-f (x) + ;; Bsetcar + (setcar x 3)) + +(defun comp-tests-integerp-f (x) + ;; Bintegerp + (integerp x)) +(defun comp-tests-numberp-f (x) + ;; Bnumberp + (numberp x)) + +(defun comp-tests-discardn-f (x) + ;; BdiscardN + (1+ (let ((a 1) + (_b) + (_c)) + a))) +(defun comp-tests-insertn-f (a b c d) + ;; Binsert + (insert a b c d)) + +(defun comp-tests-err-arith-f () + (/ 1 0)) +(defun comp-tests-err-foo-f () + (error "foo")) + +;;FIXME: horrible... +(defun comp-tests-condition-case-0-f () + ;; Bpushhandler Bpophandler + (condition-case + err + (comp-tests-err-arith-f) + (arith-error (concat "arith-error " + (error-message-string err) + " catched")) + (error (concat "error " + (error-message-string err) + " catched")))) +(defun comp-tests-condition-case-1-f () + ;; Bpushhandler Bpophandler + (condition-case + err + (comp-tests-err-foo-f) + (arith-error (concat "arith-error " + (error-message-string err) + " catched")) + (error (concat "error " + (error-message-string err) + " catched")))) +(defun comp-tests-catch-f (f) + (catch 'foo + (funcall f))) +(defun comp-tests-throw-f (x) + (throw 'foo x)) + +;; (defun comp-tests-buff0-f () +;; (with-temp-buffer +;; (insert "foo") +;; (buffer-string))) + +;;;;;;;;;;;;;;;;;;;; +;; Tromey's tests ;; +;;;;;;;;;;;;;;;;;;;; + +;; Test Bconsp. +(defun comp-test-consp (x) (consp x)) + +;; Test Blistp. +(defun comp-test-listp (x) (listp x)) + +;; Test Bstringp. +(defun comp-test-stringp (x) (stringp x)) + +;; Test Bsymbolp. +(defun comp-test-symbolp (x) (symbolp x)) + +;; Test Bintegerp. +(defun comp-test-integerp (x) (integerp x)) + +;; Test Bnumberp. +(defun comp-test-numberp (x) (numberp x)) + +;; Test Badd1. +(defun comp-test-add1 (x) (1+ x)) + +;; Test Bsub1. +(defun comp-test-sub1 (x) (1- x)) + +;; Test Bneg. +(defun comp-test-negate (x) (- x)) + +;; Test Bnot. +(defun comp-test-not (x) (not x)) + +;; Test Bbobp, Beobp, Bpoint, Bpoint_min, Bpoint_max. +(defun comp-test-bobp () (bobp)) +(defun comp-test-eobp () (eobp)) +(defun comp-test-point () (point)) +(defun comp-test-point-min () (point-min)) +(defun comp-test-point-max () (point-max)) + +;; Test Bcar and Bcdr. +(defun comp-test-car (x) (car x)) +(defun comp-test-cdr (x) (cdr x)) + +;; Test Bcar_safe and Bcdr_safe. +(defun comp-test-car-safe (x) (car-safe x)) +(defun comp-test-cdr-safe (x) (cdr-safe x)) + +;; Test Beq. +(defun comp-test-eq (x y) (eq x y)) + +;; Test Bgotoifnil. +(defun comp-test-if (x y) (if x x y)) + +;; Test Bgotoifnilelsepop. +(defun comp-test-and (x y) (and x y)) + +;; Test Bgotoifnonnilelsepop. +(defun comp-test-or (x y) (or x y)) + +;; Test Bsave_excursion. +(defun comp-test-save-excursion () + (save-excursion + (insert "XYZ"))) + +;; Test Bcurrent_buffer. +(defun comp-test-current-buffer () (current-buffer)) + +;; Test Bgtr. +(defun comp-test-> (a b) + (> a b)) + +;; Test Bpushcatch. +(defun comp-test-catch (&rest l) + (catch 'done + (dolist (v l) + (when (> v 23) + (throw 'done v))))) + +;; Test Bmemq. +(defun comp-test-memq (val list) + (memq val list)) + +;; Test BlistN. +(defun comp-test-listN (x) + (list x x x x x x x x x x x x x x x x)) + +;; Test BconcatN. +(defun comp-test-concatN (x) + (concat x x x x x x)) + +;; Test optional and rest arguments. +(defun comp-test-opt-rest (a &optional b &rest c) + (list a b c)) + +;; Test for too many arguments. +(defun comp-test-opt (a &optional b) + (cons a b)) + +;; ;; Test for unwind-protect. +;; (defvar comp-test-up-val nil) +;; (defun comp-test-unwind-protect (fun) +;; (setq comp-test-up-val nil) +;; (unwind-protect +;; (progn +;; (setq comp-test-up-val 23) +;; (funcall fun) +;; (setq comp-test-up-val 24)) +;; (setq comp-test-up-val 999))) + +;;; comp-test-funcs.el ends here diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 71a36ed591..ea1aab6e4c 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -26,132 +26,69 @@ ;;; Code: (require 'ert) -(require 'comp) (require 'cl-lib) +(require 'comp) -(setq comp-speed 3) - -(defun comp-test-apply (func &rest args) - (unless (subrp (symbol-function func)) - (native-compile func) - (cl-assert (symbol-name func)) - (load (concat (symbol-name func) ".eln"))) - (apply func args)) - -(defun comp-mashup (&rest args) - "Mash-up ARGS and return a symbol." - (intern (apply #'concat - (mapcar (lambda (x) - (cl-etypecase x - (symbol (symbol-name x)) - (string x))) - args)))) - -;; (setq garbage-collection-messages t) +(setq comp-speed 0) -(defvar comp-tests-var1 3) +(defconst comp-test-src + (concat (file-name-directory (or load-file-name buffer-file-name)) + "comp-test-funcs.el")) -(add-to-list 'load-path "/home/andcor03/emacs/src") +(message "Compiling %s" comp-test-src) +(native-compile comp-test-src) +(load (concat comp-test-src "n")) (ert-deftest comp-tests-varref () "Testing varref." - (defun comp-tests-varref-f () - comp-tests-var1) - - (should (= (comp-test-apply #'comp-tests-varref-f) 3))) + (should (= (comp-tests-varref-f) 3))) (ert-deftest comp-tests-list () "Testing cons car cdr." - (defun comp-tests-list-f () - (list 1 2 3)) - (defun comp-tests-list2-f (a b c) - (list a b c)) - (defun comp-tests-car-f (x) - ;; Bcar - (car x)) - (defun comp-tests-cdr-f (x) - ;; Bcdr - (cdr x)) - (defun comp-tests-car-safe-f (x) - ;; Bcar_safe - (car-safe x)) - (defun comp-tests-cdr-safe-f (x) - ;; Bcdr_safe - (cdr-safe x)) - - (should (equal (comp-test-apply #'comp-tests-list-f) '(1 2 3))) - (should (equal (comp-test-apply #'comp-tests-list2-f 1 2 3) '(1 2 3))) - (should (= (comp-test-apply #'comp-tests-car-f '(1 . 2)) 1)) - (should (null (comp-test-apply #'comp-tests-car-f nil))) + (should (equal (comp-tests-list-f) '(1 2 3))) + (should (equal (comp-tests-list2-f 1 2 3) '(1 2 3))) + (should (= (comp-tests-car-f '(1 . 2)) 1)) + (should (null (comp-tests-car-f nil))) (should (= (condition-case err - (comp-test-apply #'comp-tests-car-f 3) + (comp-tests-car-f 3) (error 10)) 10)) - (should (= (comp-test-apply #'comp-tests-cdr-f '(1 . 2)) 2)) - (should (null (comp-test-apply #'comp-tests-cdr-f nil))) + (should (= (comp-tests-cdr-f '(1 . 2)) 2)) + (should (null (comp-tests-cdr-f nil))) (should (= (condition-case err - (comp-test-apply #'comp-tests-cdr-f 3) + (comp-tests-cdr-f 3) (error 10)) 10)) - (should (= (comp-test-apply #'comp-tests-car-safe-f '(1 . 2)) 1)) - (should (null (comp-test-apply #'comp-tests-car-safe-f 'a))) - (should (= (comp-test-apply #'comp-tests-cdr-safe-f '(1 . 2)) 2)) - (should (null (comp-test-apply #'comp-tests-cdr-safe-f 'a)))) + (should (= (comp-tests-car-safe-f '(1 . 2)) 1)) + (should (null (comp-tests-car-safe-f 'a))) + (should (= (comp-tests-cdr-safe-f '(1 . 2)) 2)) + (should (null (comp-tests-cdr-safe-f 'a)))) (ert-deftest comp-tests-cons-car-cdr () "Testing cons car cdr." - (defun comp-tests-cons-car-f () - (car (cons 1 2))) - - (defun comp-tests-cons-cdr-f (x) - (cdr (cons 'foo x))) - - (should (= (comp-test-apply #'comp-tests-cons-car-f) 1)) - (should (= (comp-test-apply #'comp-tests-cons-cdr-f 3) 3))) + (should (= (comp-tests-cons-car-f) 1)) + (should (= (comp-tests-cons-cdr-f 3) 3))) (ert-deftest comp-tests-varset () "Testing varset." - (defun comp-tests-varset-f () - (setq comp-tests-var1 55)) - - (comp-test-apply #'comp-tests-varset-f) - + (comp-tests-varset-f) (should (= comp-tests-var1 55))) (ert-deftest comp-tests-length () "Testing length." - (defun comp-tests-length-f () - (length '(1 2 3))) - - (should (= (comp-test-apply #'comp-tests-length-f) 3))) + (should (= (comp-tests-length-f) 3))) (ert-deftest comp-tests-aref-aset () "Testing aref and aset." - (defun comp-tests-aref-aset-f () - (let ((vec [1 2 3])) - (aset vec 2 100) - (aref vec 2))) - - (should (= (comp-test-apply #'comp-tests-aref-aset-f) 100))) + (should (= (comp-tests-aref-aset-f) 100))) (ert-deftest comp-tests-symbol-value () "Testing aref and aset." - (defvar comp-tests-var2 3) - (defun comp-tests-symbol-value-f () - (symbol-value 'comp-tests-var2)) - - (should (= (comp-test-apply #'comp-tests-symbol-value-f) 3))) + (should (= (comp-tests-symbol-value-f) 3))) (ert-deftest comp-tests-concat () "Testing concatX opcodes." - (defun comp-tests-concat-f (x) - (concat "a" "b" "c" "d" - (concat "a" "b" "c" (concat "a" "b" (concat "foo" x))))) - - (should (string= (comp-test-apply #'comp-tests-concat-f "bar") "abcdabcabfoobar"))) - -(defun comp-tests-ffuncall-callee-f (x y z) - (list x y z)) + (should (string= (comp-tests-concat-f "bar") "abcdabcabfoobar"))) (ert-deftest comp-tests-ffuncall () "Test calling conventions." @@ -159,117 +96,71 @@ ;; (defun comp-tests-ffuncall-caller-f () ;; (comp-tests-ffuncall-callee-f 1 2 3)) - ;; (should (equal (comp-test-apply #'comp-tests-ffuncall-caller-f) '(1 2 3))) + ;; (should (equal (comp-tests-ffuncall-caller-f) '(1 2 3))) ;; ;; After it gets compiled ;; (native-compile #'comp-tests-ffuncall-callee-f) - ;; (should (equal (comp-test-apply #'comp-tests-ffuncall-caller-f) '(1 2 3))) + ;; (should (equal (comp-tests-ffuncall-caller-f) '(1 2 3))) ;; ;; Recompiling the caller once with callee already compiled ;; (defun comp-tests-ffuncall-caller-f () ;; (comp-tests-ffuncall-callee-f 1 2 3)) - ;; (should (equal (comp-test-apply #'comp-tests-ffuncall-caller-f) '(1 2 3))) - - (defun comp-tests-ffuncall-callee-optional-f (a b &optional c d) - (list a b c d)) + ;; (should (equal (comp-tests-ffuncall-caller-f) '(1 2 3))) - (should (equal (comp-test-apply #'comp-tests-ffuncall-callee-optional-f 1 2 3 4) + (should (equal (comp-tests-ffuncall-callee-optional-f 1 2 3 4) '(1 2 3 4))) - (should (equal (comp-test-apply #'comp-tests-ffuncall-callee-optional-f 1 2 3) + (should (equal (comp-tests-ffuncall-callee-optional-f 1 2 3) '(1 2 3 nil))) - (should (equal (comp-test-apply #'comp-tests-ffuncall-callee-optional-f 1 2) + (should (equal (comp-tests-ffuncall-callee-optional-f 1 2) '(1 2 nil nil))) - (defun comp-tests-ffuncall-callee-rest-f (a b &rest c) - (list a b c)) - - (should (equal (comp-test-apply #'comp-tests-ffuncall-callee-rest-f 1 2) + (should (equal (comp-tests-ffuncall-callee-rest-f 1 2) '(1 2 nil))) - (should (equal (comp-test-apply #'comp-tests-ffuncall-callee-rest-f 1 2 3) + (should (equal (comp-tests-ffuncall-callee-rest-f 1 2 3) '(1 2 (3)))) - (should (equal (comp-test-apply #'comp-tests-ffuncall-callee-rest-f 1 2 3 4) + (should (equal (comp-tests-ffuncall-callee-rest-f 1 2 3 4) '(1 2 (3 4)))) - (defun comp-tests-ffuncall-native-f () - "Call a primitive with no dedicate op." - (make-vector 1 nil)) - - (should (equal (comp-test-apply #'comp-tests-ffuncall-native-f) [nil])) + (should (equal (comp-tests-ffuncall-native-f) [nil])) - (defun comp-tests-ffuncall-native-rest-f () - "Call a primitive with no dedicate op with &rest." - (vector 1 2 3)) + (should (equal (comp-tests-ffuncall-native-rest-f) [1 2 3])) - (should (equal (comp-test-apply #'comp-tests-ffuncall-native-rest-f) [1 2 3])) - - (defun comp-tests-ffuncall-apply-many-f (x) - (apply #'list x)) - - (should (equal (comp-test-apply #'comp-tests-ffuncall-apply-many-f '(1 2 3)) + (should (equal (comp-tests-ffuncall-apply-many-f '(1 2 3)) '(1 2 3))) - (defun comp-tests-ffuncall-lambda-f (x) - (let ((fun (lambda (x) - (1+ x)))) - (funcall fun x))) - - (should (= (comp-test-apply #'comp-tests-ffuncall-lambda-f 1) 2))) + (should (= (comp-tests-ffuncall-lambda-f 1) 2))) (ert-deftest comp-tests-jump-table () "Testing jump tables" - (defun comp-tests-jump-table-1-f (x) - (pcase x - ('x 'a) - ('y 'b) - (_ 'c))) - - (should (eq (comp-test-apply #'comp-tests-jump-table-1-f 'x) 'a)) - (should (eq (comp-test-apply #'comp-tests-jump-table-1-f 'y) 'b)) - (should (eq (comp-test-apply #'comp-tests-jump-table-1-f 'xxx) 'c))) + (should (eq (comp-tests-jump-table-1-f 'x) 'a)) + (should (eq (comp-tests-jump-table-1-f 'y) 'b)) + (should (eq (comp-tests-jump-table-1-f 'xxx) 'c))) (ert-deftest comp-tests-conditionals () "Testing conditionals." - (defun comp-tests-conditionals-1-f (x) - ;; Generate goto-if-nil - (if x 1 2)) - (defun comp-tests-conditionals-2-f (x) - ;; Generate goto-if-nil-else-pop - (when x - 1340)) - - (should (= (comp-test-apply #'comp-tests-conditionals-1-f t) 1)) - (should (= (comp-test-apply #'comp-tests-conditionals-1-f nil) 2)) - (should (= (comp-test-apply #'comp-tests-conditionals-2-f t) 1340)) - (should (eq (comp-test-apply #'comp-tests-conditionals-2-f nil) nil))) + (should (= (comp-tests-conditionals-1-f t) 1)) + (should (= (comp-tests-conditionals-1-f nil) 2)) + (should (= (comp-tests-conditionals-2-f t) 1340)) + (should (eq (comp-tests-conditionals-2-f nil) nil))) (ert-deftest comp-tests-fixnum () "Testing some fixnum inline operation." - (defun comp-tests-fixnum-1-minus-f (x) - ;; Bsub1 - (1- x)) - (defun comp-tests-fixnum-1-plus-f (x) - ;; Badd1 - (1+ x)) - (defun comp-tests-fixnum-minus-f (x) - ;; Bnegate - (- x)) - - (should (= (comp-test-apply #'comp-tests-fixnum-1-minus-f 10) 9)) - (should (= (comp-test-apply #'comp-tests-fixnum-1-minus-f most-negative-fixnum) + (should (= (comp-tests-fixnum-1-minus-f 10) 9)) + (should (= (comp-tests-fixnum-1-minus-f most-negative-fixnum) (1- most-negative-fixnum))) (should (equal (condition-case err (comp-tests-fixnum-1-minus-f 'a) (error err)) '(wrong-type-argument number-or-marker-p a))) - (should (= (comp-test-apply #'comp-tests-fixnum-1-plus-f 10) 11)) - (should (= (comp-test-apply #'comp-tests-fixnum-1-plus-f most-positive-fixnum) + (should (= (comp-tests-fixnum-1-plus-f 10) 11)) + (should (= (comp-tests-fixnum-1-plus-f most-positive-fixnum) (1+ most-positive-fixnum))) (should (equal (condition-case err (comp-tests-fixnum-1-plus-f 'a) (error err)) '(wrong-type-argument number-or-marker-p a))) - (should (= (comp-test-apply #'comp-tests-fixnum-minus-f 10) -10)) - (should (= (comp-test-apply #'comp-tests-fixnum-minus-f most-negative-fixnum) + (should (= (comp-tests-fixnum-minus-f 10) -10)) + (should (= (comp-tests-fixnum-minus-f most-negative-fixnum) (- most-negative-fixnum))) (should (equal (condition-case err (comp-tests-fixnum-minus-f 'a) @@ -278,49 +169,26 @@ (ert-deftest comp-tests-arith-comp () "Testing arithmetic comparisons." - (defun comp-tests-eqlsign-f (x y) - ;; Beqlsign - (= x y)) - (defun comp-tests-gtr-f (x y) - ;; Bgtr - (> x y)) - (defun comp-tests-lss-f (x y) - ;; Blss - (< x y)) - (defun comp-tests-les-f (x y) - ;; Bleq - (<= x y)) - (defun comp-tests-geq-f (x y) - ;; Bgeq - (>= x y)) - - (should (eq (comp-test-apply #'comp-tests-eqlsign-f 4 3) nil)) - (should (eq (comp-test-apply #'comp-tests-eqlsign-f 3 3) t)) - (should (eq (comp-test-apply #'comp-tests-eqlsign-f 2 3) nil)) - (should (eq (comp-test-apply #'comp-tests-gtr-f 4 3) t)) - (should (eq (comp-test-apply #'comp-tests-gtr-f 3 3) nil)) - (should (eq (comp-test-apply #'comp-tests-gtr-f 2 3) nil)) - (should (eq (comp-test-apply #'comp-tests-lss-f 4 3) nil)) - (should (eq (comp-test-apply #'comp-tests-lss-f 3 3) nil)) - (should (eq (comp-test-apply #'comp-tests-lss-f 2 3) t)) - (should (eq (comp-test-apply #'comp-tests-les-f 4 3) nil)) - (should (eq (comp-test-apply #'comp-tests-les-f 3 3) t)) - (should (eq (comp-test-apply #'comp-tests-les-f 2 3) t)) - (should (eq (comp-test-apply #'comp-tests-geq-f 4 3) t)) - (should (eq (comp-test-apply #'comp-tests-geq-f 3 3) t)) - (should (eq (comp-test-apply #'comp-tests-geq-f 2 3) nil))) + (should (eq (comp-tests-eqlsign-f 4 3) nil)) + (should (eq (comp-tests-eqlsign-f 3 3) t)) + (should (eq (comp-tests-eqlsign-f 2 3) nil)) + (should (eq (comp-tests-gtr-f 4 3) t)) + (should (eq (comp-tests-gtr-f 3 3) nil)) + (should (eq (comp-tests-gtr-f 2 3) nil)) + (should (eq (comp-tests-lss-f 4 3) nil)) + (should (eq (comp-tests-lss-f 3 3) nil)) + (should (eq (comp-tests-lss-f 2 3) t)) + (should (eq (comp-tests-les-f 4 3) nil)) + (should (eq (comp-tests-les-f 3 3) t)) + (should (eq (comp-tests-les-f 2 3) t)) + (should (eq (comp-tests-geq-f 4 3) t)) + (should (eq (comp-tests-geq-f 3 3) t)) + (should (eq (comp-tests-geq-f 2 3) nil))) (ert-deftest comp-tests-setcarcdr () "Testing setcar setcdr." - (defun comp-tests-setcar-f (x y) - (setcar x y) - x) - (defun comp-tests-setcdr-f (x y) - (setcdr x y) - x) - - (should (equal (comp-test-apply #'comp-tests-setcar-f '(10 . 10) 3) '(3 . 10))) - (should (equal (comp-test-apply #'comp-tests-setcdr-f '(10 . 10) 3) '(10 . 3))) + (should (equal (comp-tests-setcar-f '(10 . 10) 3) '(3 . 10))) + (should (equal (comp-tests-setcdr-f '(10 . 10) 3) '(10 . 3))) (should (equal (condition-case err (comp-tests-setcar-f 3 10) @@ -328,24 +196,12 @@ '(wrong-type-argument consp 3))) (should (equal (condition-case err - (comp-test-apply #'comp-tests-setcdr-f 3 10) + (comp-tests-setcdr-f 3 10) (error err)) '(wrong-type-argument consp 3)))) (ert-deftest comp-tests-bubble-sort () "Run bubble sort." - (defun comp-bubble-sort-f (list) - (let ((i (length list))) - (while (> i 1) - (let ((b list)) - (while (cdr b) - (when (< (cadr b) (car b)) - (setcar b (prog1 (cadr b) - (setcdr b (cons (car b) (cddr b)))))) - (setq b (cdr b)))) - (setq i (1- i))) - list)) - (let* ((list1 (mapcar 'random (make-list 1000 most-positive-fixnum))) (list2 (copy-sequence list1))) (should (equal (comp-bubble-sort-f list1) @@ -353,50 +209,26 @@ (ert-deftest comp-test-apply () "Test some inlined list functions." - (defun comp-tests-consp-f (x) - ;; Bconsp - (consp x)) - (defun comp-tests-setcar2-f (x) - ;; Bsetcar - (setcar x 3)) - - (should (eq (comp-test-apply #'comp-tests-consp-f '(1)) t)) - (should (eq (comp-test-apply #'comp-tests-consp-f 1) nil)) + (should (eq (comp-tests-consp-f '(1)) t)) + (should (eq (comp-tests-consp-f 1) nil)) (let ((x (cons 1 2))) - (should (= (comp-test-apply #'comp-tests-setcar2-f x) 3)) + (should (= (comp-tests-setcar2-f x) 3)) (should (equal x '(3 . 2))))) (ert-deftest comp-tests-num-inline () "Test some inlined number functions." - (defun comp-tests-integerp-f (x) - ;; Bintegerp - (integerp x)) - (defun comp-tests-numberp-f (x) - ;; Bnumberp - (numberp x)) - - (should (eq (comp-test-apply #'comp-tests-integerp-f 1) t)) - (should (eq (comp-test-apply #'comp-tests-integerp-f '(1)) nil)) - (should (eq (comp-test-apply #'comp-tests-integerp-f 3.5) nil)) - (should (eq (comp-test-apply #'comp-tests-integerp-f (1+ most-negative-fixnum)) t)) - - (should (eq (comp-test-apply #'comp-tests-numberp-f 1) t)) - (should (eq (comp-test-apply #'comp-tests-numberp-f 'a) nil)) - (should (eq (comp-test-apply #'comp-tests-numberp-f 3.5) t))) + (should (eq (comp-tests-integerp-f 1) t)) + (should (eq (comp-tests-integerp-f '(1)) nil)) + (should (eq (comp-tests-integerp-f 3.5) nil)) + (should (eq (comp-tests-integerp-f (1+ most-negative-fixnum)) t)) + + (should (eq (comp-tests-numberp-f 1) t)) + (should (eq (comp-tests-numberp-f 'a) nil)) + (should (eq (comp-tests-numberp-f 3.5) t))) (ert-deftest comp-tests-stack () "Test some stack operation." - (defun comp-tests-discardn-f (x) - ;; BdiscardN - (1+ (let ((a 1) - (_b) - (_c)) - a))) - (defun comp-tests-insertn-f (a b c d) - ;; Binsert - (insert a b c d)) - - (should (= (comp-test-apply #'comp-tests-discardn-f 10) 2)) + (should (= (comp-tests-discardn-f 10) 2)) (should (string= (with-temp-buffer (comp-tests-insertn-f "a" "b" "c" "d") (buffer-string)) @@ -405,47 +237,11 @@ (ert-deftest comp-tests-non-locals () "Test non locals." (let ((gc-cons-threshold most-positive-fixnum)) ;; FIXME!! - (defun comp-tests-err-arith-f () - (/ 1 0)) - (defun comp-tests-err-foo-f () - (error "foo")) - - (defun comp-tests-condition-case-0-f () - ;; Bpushhandler Bpophandler - (condition-case - err - (comp-tests-err-arith-f) - (arith-error (concat "arith-error " - (error-message-string err) - " catched")) - (error (concat "error " - (error-message-string err) - " catched")))) - - (defun comp-tests-condition-case-1-f () - ;; Bpushhandler Bpophandler - (condition-case - err - (comp-tests-err-foo-f) - (arith-error (concat "arith-error " - (error-message-string err) - " catched")) - (error (concat "error " - (error-message-string err) - " catched")))) - - (defun comp-tests-catch-f (f) - (catch 'foo - (funcall f))) - - (defun comp-tests-throw-f (x) - (throw 'foo x)) - - (should (string= (comp-test-apply #'comp-tests-condition-case-0-f) + (should (string= (comp-tests-condition-case-0-f) "arith-error Arithmetic error catched")) - (should (string= (comp-test-apply #'comp-tests-condition-case-1-f) + (should (string= (comp-tests-condition-case-1-f) "error foo catched")) - (should (= (comp-test-apply #'comp-tests-catch-f + (should (= (comp-tests-catch-f (lambda () (throw 'foo 3))) 3)) (should (= (catch 'foo @@ -455,283 +251,170 @@ "Try to do some longer computation to let the gc kick in." (dotimes (_ 100000) (comp-tests-cons-cdr-f 3)) - - (should (= (comp-test-apply #'comp-tests-cons-cdr-f 3) 3))) + (should (= (comp-tests-cons-cdr-f 3) 3))) (ert-deftest comp-tests-buffer () - (defun comp-tests-buff0-f () - (with-temp-buffer - (insert "foo") - (buffer-string))) - - (should (string= (comp-test-apply #'comp-tests-buff0-f) "foo"))) + (should (string= (comp-tests-buff0-f) "foo"))) ;;;;;;;;;;;;;;;;;;;; ;; Tromey's tests ;; ;;;;;;;;;;;;;;;;;;;; -;; Test Bconsp. -(defun comp-test-consp (x) (consp x)) - (ert-deftest comp-consp () - (should-not (comp-test-apply 'comp-test-consp 23)) - (should-not (comp-test-apply 'comp-test-consp nil)) - (should (comp-test-apply 'comp-test-consp '(1 . 2)))) - -;; Test Blistp. -(defun comp-test-listp (x) (listp x)) + (should-not (comp-test-consp 23)) + (should-not (comp-test-consp nil)) + (should (comp-test-consp '(1 . 2)))) (ert-deftest comp-listp () - (should-not (comp-test-apply 'comp-test-listp 23)) - (should (comp-test-apply 'comp-test-listp nil)) - (should (comp-test-apply 'comp-test-listp '(1 . 2)))) - -;; Test Bstringp. -(defun comp-test-stringp (x) (stringp x)) + (should-not (comp-test-listp 23)) + (should (comp-test-listp nil)) + (should (comp-test-listp '(1 . 2)))) (ert-deftest comp-stringp () - (should-not (comp-test-apply 'comp-test-stringp 23)) - (should-not (comp-test-apply 'comp-test-stringp nil)) - (should (comp-test-apply 'comp-test-stringp "hi"))) - -;; Test Bsymbolp. -(defun comp-test-symbolp (x) (symbolp x)) + (should-not (comp-test-stringp 23)) + (should-not (comp-test-stringp nil)) + (should (comp-test-stringp "hi"))) (ert-deftest comp-symbolp () - (should-not (comp-test-apply 'comp-test-symbolp 23)) - (should-not (comp-test-apply 'comp-test-symbolp "hi")) - (should (comp-test-apply 'comp-test-symbolp 'whatever))) - -;; Test Bintegerp. -(defun comp-test-integerp (x) (integerp x)) + (should-not (comp-test-symbolp 23)) + (should-not (comp-test-symbolp "hi")) + (should (comp-test-symbolp 'whatever))) (ert-deftest comp-integerp () - (should (comp-test-apply 'comp-test-integerp 23)) - (should-not (comp-test-apply 'comp-test-integerp 57.5)) - (should-not (comp-test-apply 'comp-test-integerp "hi")) - (should-not (comp-test-apply 'comp-test-integerp 'whatever))) - -;; Test Bnumberp. -(defun comp-test-numberp (x) (numberp x)) + (should (comp-test-integerp 23)) + (should-not (comp-test-integerp 57.5)) + (should-not (comp-test-integerp "hi")) + (should-not (comp-test-integerp 'whatever))) (ert-deftest comp-numberp () - (should (comp-test-apply 'comp-test-numberp 23)) - (should (comp-test-apply 'comp-test-numberp 57.5)) - (should-not (comp-test-apply 'comp-test-numberp "hi")) - (should-not (comp-test-apply 'comp-test-numberp 'whatever))) - -;; Test Badd1. -(defun comp-test-add1 (x) (1+ x)) + (should (comp-test-numberp 23)) + (should (comp-test-numberp 57.5)) + (should-not (comp-test-numberp "hi")) + (should-not (comp-test-numberp 'whatever))) (ert-deftest comp-add1 () - (should (eq (comp-test-apply 'comp-test-add1 23) 24)) - (should (eq (comp-test-apply 'comp-test-add1 -17) -16)) - (should (eql (comp-test-apply 'comp-test-add1 1.0) 2.0)) - (should-error (comp-test-apply 'comp-test-add1 nil) + (should (eq (comp-test-add1 23) 24)) + (should (eq (comp-test-add1 -17) -16)) + (should (eql (comp-test-add1 1.0) 2.0)) + (should-error (comp-test-add1 nil) :type 'wrong-type-argument)) -;; Test Bsub1. -(defun comp-test-sub1 (x) (1- x)) - (ert-deftest comp-sub1 () - (should (eq (comp-test-apply 'comp-test-sub1 23) 22)) - (should (eq (comp-test-apply 'comp-test-sub1 -17) -18)) - (should (eql (comp-test-apply 'comp-test-sub1 1.0) 0.0)) - (should-error (comp-test-apply 'comp-test-sub1 nil) + (should (eq (comp-test-sub1 23) 22)) + (should (eq (comp-test-sub1 -17) -18)) + (should (eql (comp-test-sub1 1.0) 0.0)) + (should-error (comp-test-sub1 nil) :type 'wrong-type-argument)) -;; Test Bneg. -(defun comp-test-negate (x) (- x)) - (ert-deftest comp-negate () - (should (eq (comp-test-apply 'comp-test-negate 23) -23)) - (should (eq (comp-test-apply 'comp-test-negate -17) 17)) - (should (eql (comp-test-apply 'comp-test-negate 1.0) -1.0)) - (should-error (comp-test-apply 'comp-test-negate nil) + (should (eq (comp-test-negate 23) -23)) + (should (eq (comp-test-negate -17) 17)) + (should (eql (comp-test-negate 1.0) -1.0)) + (should-error (comp-test-negate nil) :type 'wrong-type-argument)) -;; Test Bnot. -(defun comp-test-not (x) (not x)) - (ert-deftest comp-not () - (should (eq (comp-test-apply 'comp-test-not 23) nil)) - (should (eq (comp-test-apply 'comp-test-not nil) t)) - (should (eq (comp-test-apply 'comp-test-not t) nil))) - -;; Test Bbobp, Beobp, Bpoint, Bpoint_min, Bpoint_max. -(defun comp-test-bobp () (bobp)) -(defun comp-test-eobp () (eobp)) -(defun comp-test-point () (point)) -(defun comp-test-point-min () (point-min)) -(defun comp-test-point-max () (point-max)) + (should (eq (comp-test-not 23) nil)) + (should (eq (comp-test-not nil) t)) + (should (eq (comp-test-not t) nil))) (ert-deftest comp-bobp-and-eobp () (with-temp-buffer - (should (comp-test-apply 'comp-test-bobp)) - (should (comp-test-apply 'comp-test-eobp)) + (should (comp-test-bobp)) + (should (comp-test-eobp)) (insert "hi") (goto-char (point-min)) - (should (eq (comp-test-apply 'comp-test-point-min) (point-min))) - (should (eq (comp-test-apply 'comp-test-point) (point-min))) - (should (comp-test-apply 'comp-test-bobp)) - (should-not (comp-test-apply 'comp-test-eobp)) + (should (eq (comp-test-point-min) (point-min))) + (should (eq (comp-test-point) (point-min))) + (should (comp-test-bobp)) + (should-not (comp-test-eobp)) (goto-char (point-max)) - (should (eq (comp-test-apply 'comp-test-point-max) (point-max))) - (should (eq (comp-test-apply 'comp-test-point) (point-max))) - (should-not (comp-test-apply 'comp-test-bobp)) - (should (comp-test-apply 'comp-test-eobp)))) - -;; Test Bcar and Bcdr. -(defun comp-test-car (x) (car x)) -(defun comp-test-cdr (x) (cdr x)) + (should (eq (comp-test-point-max) (point-max))) + (should (eq (comp-test-point) (point-max))) + (should-not (comp-test-bobp)) + (should (comp-test-eobp)))) (ert-deftest comp-car-cdr () (let ((pair '(1 . b))) - (should (eq (comp-test-apply 'comp-test-car pair) 1)) - (should (eq (comp-test-apply 'comp-test-car nil) nil)) - (should-error (comp-test-apply 'comp-test-car 23) + (should (eq (comp-test-car pair) 1)) + (should (eq (comp-test-car nil) nil)) + (should-error (comp-test-car 23) :type 'wrong-type-argument) - (should (eq (comp-test-apply 'comp-test-cdr pair) 'b)) - (should (eq (comp-test-apply 'comp-test-cdr nil) nil)) - (should-error (comp-test-apply 'comp-test-cdr 23) + (should (eq (comp-test-cdr pair) 'b)) + (should (eq (comp-test-cdr nil) nil)) + (should-error (comp-test-cdr 23) :type 'wrong-type-argument))) -;; Test Bcar_safe and Bcdr_safe. -(defun comp-test-car-safe (x) (car-safe x)) -(defun comp-test-cdr-safe (x) (cdr-safe x)) - (ert-deftest comp-car-cdr-safe () (let ((pair '(1 . b))) - (should (eq (comp-test-apply 'comp-test-car-safe pair) 1)) - (should (eq (comp-test-apply 'comp-test-car-safe nil) nil)) - (should (eq (comp-test-apply 'comp-test-car-safe 23) nil)) - (should (eq (comp-test-apply 'comp-test-cdr-safe pair) 'b)) - (should (eq (comp-test-apply 'comp-test-cdr-safe nil) nil)) - (should (eq (comp-test-apply 'comp-test-cdr-safe 23) nil)))) - -;; Test Beq. -(defun comp-test-eq (x y) (eq x y)) + (should (eq (comp-test-car-safe pair) 1)) + (should (eq (comp-test-car-safe nil) nil)) + (should (eq (comp-test-car-safe 23) nil)) + (should (eq (comp-test-cdr-safe pair) 'b)) + (should (eq (comp-test-cdr-safe nil) nil)) + (should (eq (comp-test-cdr-safe 23) nil)))) (ert-deftest comp-eq () - (should (comp-test-apply 'comp-test-eq 'a 'a)) - (should (comp-test-apply 'comp-test-eq 5 5)) - (should-not (comp-test-apply 'comp-test-eq 'a 'b)) - (should-not (comp-test-apply 'comp-test-eq "x" "x"))) - -;; Test Bgotoifnil. -(defun comp-test-if (x y) (if x x y)) + (should (comp-test-eq 'a 'a)) + (should (comp-test-eq 5 5)) + (should-not (comp-test-eq 'a 'b)) + (should-not (comp-test-eq "x" "x"))) (ert-deftest comp-if () - (should (eq (comp-test-apply 'comp-test-if 'a 'b) 'a)) - (should (eq (comp-test-apply 'comp-test-if 0 23) 0)) - (should (eq (comp-test-apply 'comp-test-if nil 'b) 'b))) - -;; Test Bgotoifnilelsepop. -(defun comp-test-and (x y) (and x y)) + (should (eq (comp-test-if 'a 'b) 'a)) + (should (eq (comp-test-if 0 23) 0)) + (should (eq (comp-test-if nil 'b) 'b))) (ert-deftest comp-and () - (should (eq (comp-test-apply 'comp-test-and 'a 'b) 'b)) - (should (eq (comp-test-apply 'comp-test-and 0 23) 23)) - (should (eq (comp-test-apply 'comp-test-and nil 'b) nil))) - -;; Test Bgotoifnonnilelsepop. -(defun comp-test-or (x y) (or x y)) + (should (eq (comp-test-and 'a 'b) 'b)) + (should (eq (comp-test-and 0 23) 23)) + (should (eq (comp-test-and nil 'b) nil))) (ert-deftest comp-or () - (should (eq (comp-test-apply 'comp-test-or 'a 'b) 'a)) - (should (eq (comp-test-apply 'comp-test-or 0 23) 0)) - (should (eq (comp-test-apply 'comp-test-or nil 'b) 'b))) - -;; Test Bsave_excursion. -(defun comp-test-save-excursion () - (save-excursion - (insert "XYZ"))) - -;; Test Bcurrent_buffer. -(defun comp-test-current-buffer () (current-buffer)) + (should (eq (comp-test-or 'a 'b) 'a)) + (should (eq (comp-test-or 0 23) 0)) + (should (eq (comp-test-or nil 'b) 'b))) (ert-deftest comp-save-excursion () (with-temp-buffer - (comp-test-apply 'comp-test-save-excursion) + (comp-test-save-excursion) (should (eq (point) (point-min))) - (should (eq (comp-test-apply 'comp-test-current-buffer) (current-buffer))))) - -;; Test Bgtr. -(defun comp-test-> (a b) - (> a b)) + (should (eq (comp-test-current-buffer) (current-buffer))))) (ert-deftest comp-> () - (should (eq (comp-test-apply 'comp-test-> 0 23) nil)) - (should (eq (comp-test-apply 'comp-test-> 23 0) t))) - -;; Test Bpushcatch. -(defun comp-test-catch (&rest l) - (catch 'done - (dolist (v l) - (when (> v 23) - (throw 'done v))))) + (should (eq (comp-test-> 0 23) nil)) + (should (eq (comp-test-> 23 0) t))) (ert-deftest comp-catch () - (should (eq (comp-test-apply 'comp-test-catch 0 1 2 3 4) nil)) - (should (eq (comp-test-apply 'comp-test-catch 20 21 22 23 24 25 26 27 28) 24))) - -;; Test Bmemq. -(defun comp-test-memq (val list) - (memq val list)) + (should (eq (comp-test-catch 0 1 2 3 4) nil)) + (should (eq (comp-test-catch 20 21 22 23 24 25 26 27 28) 24))) (ert-deftest comp-memq () - (should (equal (comp-test-apply 'comp-test-memq 0 '(5 4 3 2 1 0)) '(0))) - (should (eq (comp-test-apply 'comp-test-memq 72 '(5 4 3 2 1 0)) nil))) - -;; Test BlistN. -(defun comp-test-listN (x) - (list x x x x x x x x x x x x x x x x)) + (should (equal (comp-test-memq 0 '(5 4 3 2 1 0)) '(0))) + (should (eq (comp-test-memq 72 '(5 4 3 2 1 0)) nil))) (ert-deftest comp-listN () - (should (equal (comp-test-apply 'comp-test-listN 57) + (should (equal (comp-test-listN 57) '(57 57 57 57 57 57 57 57 57 57 57 57 57 57 57 57)))) -;; Test BconcatN. -(defun comp-test-concatN (x) - (concat x x x x x x)) - (ert-deftest comp-concatN () - (should (equal (comp-test-apply 'comp-test-concatN "x") "xxxxxx"))) - -;; Test optional and rest arguments. -(defun comp-test-opt-rest (a &optional b &rest c) - (list a b c)) + (should (equal (comp-test-concatN "x") "xxxxxx"))) (ert-deftest comp-opt-rest () - (should (equal (comp-test-apply 'comp-test-opt-rest 1) '(1 nil nil))) - (should (equal (comp-test-apply 'comp-test-opt-rest 1 2) '(1 2 nil))) - (should (equal (comp-test-apply 'comp-test-opt-rest 1 2 3) '(1 2 (3)))) - (should (equal (comp-test-apply 'comp-test-opt-rest 1 2 56 57 58) + (should (equal (comp-test-opt-rest 1) '(1 nil nil))) + (should (equal (comp-test-opt-rest 1 2) '(1 2 nil))) + (should (equal (comp-test-opt-rest 1 2 3) '(1 2 (3)))) + (should (equal (comp-test-opt-rest 1 2 56 57 58) '(1 2 (56 57 58))))) -;; Test for too many arguments. -(defun comp-test-opt (a &optional b) - (cons a b)) - (ert-deftest comp-opt () - (should (equal (comp-test-apply 'comp-test-opt 23) '(23))) - (should (equal (comp-test-apply 'comp-test-opt 23 24) '(23 . 24))) - (should-error (comp-test-apply 'comp-test-opt) + (should (equal (comp-test-opt 23) '(23))) + (should (equal (comp-test-opt 23 24) '(23 . 24))) + (should-error (comp-test-opt) :type 'wrong-number-of-arguments) - (should-error (comp-test-apply 'comp-test-opt nil 24 97) + (should-error (comp-test-opt nil 24 97) :type 'wrong-number-of-arguments)) -;; Test for unwind-protect. -(defvar comp-test-up-val nil) -(defun comp-test-unwind-protect (fun) - (setq comp-test-up-val nil) - (unwind-protect - (progn - (setq comp-test-up-val 23) - (funcall fun) - (setq comp-test-up-val 24)) - (setq comp-test-up-val 999))) - (ert-deftest comp-unwind-protect () (comp-test-unwind-protect 'ignore) (should (eq comp-test-up-val 999)) commit 29fcb6ca1280fc01c652dcecc331b20cd88a5729 Author: Andrea Corallo Date: Sat Sep 7 11:17:02 2019 +0200 basic file compilation working diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 736f4f6223..ec7b036a67 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -563,8 +563,9 @@ Each element is (INDEX . VALUE)") (defvar byte-compile-depth 0 "Current depth of execution stack.") (defvar byte-compile-maxdepth 0 "Maximum depth of execution stack.") -;; These are use by comp.el to spill +;; These are use by comp.el to spill data out of here (defvar byte-native-compiling nil) +(defvar byte-to-native-names nil) (defvar byte-to-native-lap-output nil) (defvar byte-to-native-bytecode-output nil) @@ -2271,6 +2272,10 @@ we output that argument and the following argument QUOTED says that we have to put a quote before the list that represents a doc string reference. `defvaralias', `autoload' and `custom-declare-variable' need that." + (when byte-native-compiling + ;; Spill output for the native compiler here + (push name byte-to-native-names) + (push (apply #'vector form) byte-to-native-bytecode-output)) ;; We need to examine byte-compile-dynamic-docstrings ;; in the input buffer (now current), not in the output buffer. (let ((dynamic-docstrings byte-compile-dynamic-docstrings)) @@ -3121,9 +3126,8 @@ for symbols generated by the byte compiler itself." (out (list 'byte-code (byte-compile-lapcode byte-compile-output) byte-compile-vector byte-compile-maxdepth))) (when byte-native-compiling - ;; Spill output for the native compiler here - (push byte-compile-output byte-to-native-lap-output) - (push out byte-to-native-bytecode-output)) + ;; Spill output for the native compiler here + (push byte-compile-output byte-to-native-lap-output)) out)) ;; it's a trivial function ((cdr body) (cons 'progn (nreverse body))) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index cfaf453932..1a426560ba 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -243,6 +243,8 @@ Put PREFIX in front of it." (defun comp-decrypt-lambda-list (x) "Decript lambda list X." + (unless (fixnump x) + (error "Can't native compile a non lexical scoped function")) (let ((rest (not (= (logand x 128) 0))) (mandatory (logand x 127)) (nonrest (ash x -8))) @@ -254,7 +256,7 @@ Put PREFIX in front of it." :nonrest nonrest)))) (defun comp-spill-lap-function (function-name) - "Spill LAP for FUNCTION-NAME." + "Byte compile FUNCTION-NAME spilling data from the byte compiler." (let* ((f (symbol-function function-name)) (func (make-comp-func :symbol-name function-name :func f @@ -268,23 +270,45 @@ Put PREFIX in front of it." (comp-within-log-buff (cl-prettyprint byte-to-native-lap-output)) (let ((lambda-list (aref (comp-func-byte-func func) 0))) - (if (fixnump lambda-list) - (setf (comp-func-args func) - (comp-decrypt-lambda-list lambda-list)) - (error "Can't native compile a non lexical scoped function"))) + (setf (comp-func-args func) + (comp-decrypt-lambda-list lambda-list))) (setf (comp-func-lap func) (car byte-to-native-lap-output)) (setf (comp-func-frame-size func) (aref (comp-func-byte-func func) 3)) func)) +(defun comp-spill-lap-functions-file (filename) + "Byte compile FILENAME spilling data from the byte compiler." + (byte-compile-file filename) + (cl-assert (= (length byte-to-native-names) + (length byte-to-native-lap-output) + (length byte-to-native-bytecode-output))) + (cl-loop for function-name in byte-to-native-names + for lap in byte-to-native-lap-output + for bytecode in byte-to-native-bytecode-output + for lambda-list = (aref bytecode 0) + for func = (make-comp-func :symbol-name function-name + :byte-func bytecode + :c-func-name (comp-c-func-name + function-name + "F") + :args (comp-decrypt-lambda-list lambda-list) + :lap lap + :frame-size (aref bytecode 3)) + do (comp-within-log-buff + (cl-prettyprint lap)) + collect func)) + (defun comp-spill-lap (input) "Byte compile and spill the LAP rapresentation for INPUT. If INPUT is a symbol this is the function-name to be compiled. If INPUT is a string this is the file path to be compiled." (let ((byte-native-compiling t) - (byte-to-native-lap-output ())) + (byte-to-native-names ()) + (byte-to-native-lap-output ()) + (byte-to-native-bytecode-output ())) (cl-typecase input (symbol (list (comp-spill-lap-function input))) - (string (error "To be implemented"))))) + (string (comp-spill-lap-functions-file input))))) ;;; Limplification pass specific code. @@ -905,11 +929,11 @@ Prepare every functions for final compilation and drive the C side." (defun native-compile (input) "Compile INPUT into native code. This is the entrypoint for the Emacs Lisp native compiler. -If INPUT is a symbol this is the function-name to be compiled. -If INPUT is a string this is the file path to be compiled." +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." (unless (or (symbolp input) (stringp input)) - (error "Trying to native compile something not a function or file")) + (error "Trying to native compile something not a symbol function or file")) (let ((data input) (comp-ctxt (make-comp-ctxt :output (if (symbolp input) (symbol-name input) diff --git a/src/comp.c b/src/comp.c index 905cc70b6b..07c779369c 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3057,9 +3057,9 @@ helper_PSEUDOVECTOR_TYPEP_XUNTAG (const union vectorlike_header *a, } -/*********************************/ -/* Native elisp load functions. */ -/*********************************/ +/**************************************/ +/* Functions used to load eln files. */ +/**************************************/ static Lisp_Object Vnative_elisp_refs_hash; commit 37a794ce21aa52180c3b5037c3825efee91ee7a0 Author: Andrea Corallo Date: Sat Sep 7 08:57:07 2019 +0200 split final pass + some code rework diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index d7f6f606e8..cfaf453932 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -52,7 +52,8 @@ "Every pass has the right to bind what it likes here.") (defconst comp-passes '(comp-spill-lap - comp-limplify) + comp-limplify + comp-final) "Passes to be executed in order.") (defconst comp-known-ret-types '((cons . cons)) @@ -78,8 +79,9 @@ "Hash table lap-op -> stack adjustment.")) (cl-defstruct comp-ctxt - "This structure is to serve al relocation creation for the current compiler - context." + "Lisp side of the compiler context." + (output nil :'string + :documentation "Target output filename for the compilation.") (funcs () :type list :documentation "Exported functions list.") (funcs-h (make-hash-table) :type hash-table @@ -282,8 +284,7 @@ If INPUT is a string this is the file path to be compiled." (byte-to-native-lap-output ())) (cl-typecase input (symbol (list (comp-spill-lap-function input))) - (string (error "To be implemented")) - (otherwise (error "Trying to native compile something not a function or file"))))) + (string (error "To be implemented"))))) ;;; Limplification pass specific code. @@ -857,10 +858,11 @@ the annotation emission." funcs)) -;;; C function wrappers +;;; Final pass specific code. (defun comp-compile-ctxt-to-file (name) - "Compile as native code the current context naming it NAME." + "Compile as native code the current context naming it NAME. +Prepare every functions for final compilation and drive the C side." (cl-assert (= (length (comp-ctxt-data-relocs-l comp-ctxt)) (hash-table-count (comp-ctxt-data-relocs-idx comp-ctxt)))) (setf (comp-ctxt-funcs comp-ctxt) @@ -883,9 +885,19 @@ the annotation emission." "Add FUNC to the current compiler contex." (puthash (comp-func-symbol-name func) func - (comp-ctxt-funcs-h comp-ctxt)) - ;; (comp--add-func-to-ctxt func) - ) + (comp-ctxt-funcs-h comp-ctxt))) + +(defun comp-final (data) + "Final pass driving DATA into the C side for code emission." + (let (compile-result) + (comp--init-ctxt) + (unwind-protect + (progn + (mapc #'comp-add-func-to-ctxt data) + (setq compile-result + (comp-compile-ctxt-to-file (comp-ctxt-output comp-ctxt)))) + (and (comp--release-ctxt) + compile-result)))) ;;; Entry points. @@ -895,20 +907,16 @@ the annotation emission." This is the entrypoint for the Emacs Lisp native compiler. If INPUT is a symbol this is the function-name to be compiled. If INPUT is a string this is the file path to be compiled." + (unless (or (symbolp input) + (stringp input)) + (error "Trying to native compile something not a function or file")) (let ((data input) - (comp-ctxt (make-comp-ctxt))) + (comp-ctxt (make-comp-ctxt :output (if (symbolp input) + (symbol-name input) + (file-name-sans-extension input))))) (mapc (lambda (pass) (setq data (funcall pass data))) - comp-passes) - ;; Once we have the final LIMPLE we jump into C. - (comp--init-ctxt) - (unwind-protect - (progn - (mapc #'comp-add-func-to-ctxt data) - (comp-compile-ctxt-to-file (if (symbolp input) - (symbol-name input) - (file-name-sans-extension input)))) - (comp--release-ctxt)))) + comp-passes))) (provide 'comp) commit 3d9d7b34511bc3601efa2ab4ad24d62c73b80cc0 Author: Andrea Corallo Date: Sat Sep 7 08:18:08 2019 +0200 generalize code into comp.el for compile multiple funcitons diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 04f19426f1..736f4f6223 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -3117,12 +3117,14 @@ for symbols generated by the byte compiler itself." (not (delq nil (mapcar 'consp (cdr (car body)))))))) (setq rest (cdr rest))) rest)) - ;; Spill lap output here - (when byte-native-compiling - (push byte-compile-output byte-to-native-lap-output)) - (let ((byte-compile-vector (byte-compile-constants-vector))) - (list 'byte-code (byte-compile-lapcode byte-compile-output) - byte-compile-vector byte-compile-maxdepth))) + (let* ((byte-compile-vector (byte-compile-constants-vector)) + (out (list 'byte-code (byte-compile-lapcode byte-compile-output) + byte-compile-vector byte-compile-maxdepth))) + (when byte-native-compiling + ;; Spill output for the native compiler here + (push byte-compile-output byte-to-native-lap-output) + (push out byte-to-native-bytecode-output)) + out)) ;; it's a trivial function ((cdr body) (cons 'progn (nreverse body))) ((car body))))) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 2e35cd31d6..d7f6f606e8 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -251,22 +251,39 @@ Put PREFIX in front of it." (make-comp-nargs :min mandatory :nonrest nonrest)))) -(defun comp-spill-lap (func) - "Byte compile and spill the LAP rapresentation for FUNC." +(defun comp-spill-lap-function (function-name) + "Spill LAP for FUNCTION-NAME." + (let* ((f (symbol-function function-name)) + (func (make-comp-func :symbol-name function-name + :func f + :c-func-name (comp-c-func-name + function-name + "F")))) + (when (byte-code-function-p f) + (error "Can't native compile an already bytecompiled function")) + (setf (comp-func-byte-func func) + (byte-compile (comp-func-symbol-name func))) + (comp-within-log-buff + (cl-prettyprint byte-to-native-lap-output)) + (let ((lambda-list (aref (comp-func-byte-func func) 0))) + (if (fixnump lambda-list) + (setf (comp-func-args func) + (comp-decrypt-lambda-list lambda-list)) + (error "Can't native compile a non lexical scoped function"))) + (setf (comp-func-lap func) (car byte-to-native-lap-output)) + (setf (comp-func-frame-size func) (aref (comp-func-byte-func func) 3)) + func)) + +(defun comp-spill-lap (input) + "Byte compile and spill the LAP rapresentation for INPUT. +If INPUT is a symbol this is the function-name to be compiled. +If INPUT is a string this is the file path to be compiled." (let ((byte-native-compiling t) (byte-to-native-lap-output ())) - (setf (comp-func-byte-func func) - (byte-compile (comp-func-symbol-name func))) - (comp-within-log-buff - (cl-prettyprint byte-to-native-lap-output)) - (let ((lambda-list (aref (comp-func-byte-func func) 0))) - (if (fixnump lambda-list) - (setf (comp-func-args func) - (comp-decrypt-lambda-list lambda-list)) - (error "Can't native compile a non lexical scoped function"))) - (setf (comp-func-lap func) (car byte-to-native-lap-output)) - (setf (comp-func-frame-size func) (aref (comp-func-byte-func func) 3)) - func)) + (cl-typecase input + (symbol (list (comp-spill-lap-function input))) + (string (error "To be implemented")) + (otherwise (error "Trying to native compile something not a function or file"))))) ;;; Limplification pass specific code. @@ -806,36 +823,38 @@ the annotation emission." (comp-emit-block 'entry_rest_args) (comp-emit `(set-rest-args-to-local ,nonrest))) -(defun comp-limplify (func) - "Given FUNC compute its LIMPLE ir." - (let* ((frame-size (comp-func-frame-size func)) - (comp-func func) - (comp-pass (make-comp-limplify - :sp -1 - :frame (comp-new-frame frame-size))) - (args (comp-func-args func)) - (args-min (comp-args-base-min args)) - (comp-block ())) - ;; Prologue - (comp-emit-block 'entry) - (comp-emit-annotation (concat "Lisp function: " - (symbol-name (comp-func-symbol-name func)))) - (if (comp-args-p args) - (cl-loop for i below (comp-args-max args) - do (cl-incf (comp-sp)) - do (comp-emit `(set-par-to-local ,(comp-slot) ,i))) - (let ((nonrest (comp-nargs-nonrest args))) - (comp-emit-narg-prologue args-min nonrest) - (cl-incf (comp-sp) (1+ nonrest)))) - ;; Body - (comp-emit-block 'bb_1) - (mapc #'comp-limplify-lap-inst (comp-func-lap func)) - ;; Reverse insns into all basic blocks. - (cl-loop for bb being the hash-value in (comp-func-blocks func) - do (setf (comp-block-insns bb) - (nreverse (comp-block-insns bb)))) - (comp-log-func func) - func)) +(defun comp-limplify (funcs) + "Given FUNCS compute their LIMPLE ir." + (mapcar (lambda (func) + (let* ((frame-size (comp-func-frame-size func)) + (comp-func func) + (comp-pass (make-comp-limplify + :sp -1 + :frame (comp-new-frame frame-size))) + (args (comp-func-args func)) + (args-min (comp-args-base-min args)) + (comp-block ())) + ;; Prologue + (comp-emit-block 'entry) + (comp-emit-annotation (concat "Lisp function: " + (symbol-name (comp-func-symbol-name func)))) + (if (comp-args-p args) + (cl-loop for i below (comp-args-max args) + do (cl-incf (comp-sp)) + do (comp-emit `(set-par-to-local ,(comp-slot) ,i))) + (let ((nonrest (comp-nargs-nonrest args))) + (comp-emit-narg-prologue args-min nonrest) + (cl-incf (comp-sp) (1+ nonrest)))) + ;; Body + (comp-emit-block 'bb_1) + (mapc #'comp-limplify-lap-inst (comp-func-lap func)) + ;; Reverse insns into all basic blocks. + (cl-loop for bb being the hash-value in (comp-func-blocks func) + do (setf (comp-block-insns bb) + (nreverse (comp-block-insns bb)))) + (comp-log-func func) + func)) + funcs)) ;;; C function wrappers @@ -871,29 +890,25 @@ the annotation emission." ;;; Entry points. -(defun native-compile (func-symbol-name) - "FUNC-SYMBOL-NAME is the function name to be compiled into native code." - (if-let ((f (symbol-function func-symbol-name))) - (progn - (when (byte-code-function-p f) - (error "Can't native compile an already bytecompiled function")) - (let ((func (make-comp-func :symbol-name func-symbol-name - :func f - :c-func-name (comp-c-func-name - func-symbol-name - "F"))) - (comp-ctxt (make-comp-ctxt))) - (mapc (lambda (pass) - (funcall pass func)) - comp-passes) - ;; Once we have the final LIMPLE we jump into C. - (comp--init-ctxt) - (unwind-protect - (progn - (comp-add-func-to-ctxt func) - (comp-compile-ctxt-to-file (symbol-name func-symbol-name))) - (comp--release-ctxt)))) - (error "Trying to native compile something not a function"))) +(defun native-compile (input) + "Compile INPUT into native code. +This is the entrypoint for the Emacs Lisp native compiler. +If INPUT is a symbol this is the function-name to be compiled. +If INPUT is a string this is the file path to be compiled." + (let ((data input) + (comp-ctxt (make-comp-ctxt))) + (mapc (lambda (pass) + (setq data (funcall pass data))) + comp-passes) + ;; Once we have the final LIMPLE we jump into C. + (comp--init-ctxt) + (unwind-protect + (progn + (mapc #'comp-add-func-to-ctxt data) + (comp-compile-ctxt-to-file (if (symbolp input) + (symbol-name input) + (file-name-sans-extension input)))) + (comp--release-ctxt)))) (provide 'comp) commit 2b51859d447cf2914cb64936f18231363d971b21 Author: Andrea Corallo Date: Fri Sep 6 19:33:16 2019 +0200 prepare for file compilation diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index ca7c67e690..04f19426f1 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -563,9 +563,10 @@ Each element is (INDEX . VALUE)") (defvar byte-compile-depth 0 "Current depth of execution stack.") (defvar byte-compile-maxdepth 0 "Maximum depth of execution stack.") -;; These are use by comp.el to spill lap -(defvar byte-compile-spilling-lap nil) -(defvar byte-compile-lap-output nil) +;; These are use by comp.el to spill +(defvar byte-native-compiling nil) +(defvar byte-to-native-lap-output nil) +(defvar byte-to-native-bytecode-output nil) ;;; The byte codes; this information is duplicated in bytecomp.c @@ -3117,7 +3118,8 @@ for symbols generated by the byte compiler itself." (setq rest (cdr rest))) rest)) ;; Spill lap output here - (setq byte-compile-lap-output byte-compile-output) + (when byte-native-compiling + (push byte-compile-output byte-to-native-lap-output)) (let ((byte-compile-vector (byte-compile-constants-vector))) (list 'byte-code (byte-compile-lapcode byte-compile-output) byte-compile-vector byte-compile-maxdepth))) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 3a01bb1238..2e35cd31d6 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -253,17 +253,18 @@ Put PREFIX in front of it." (defun comp-spill-lap (func) "Byte compile and spill the LAP rapresentation for FUNC." - (let (byte-compile-lap-output) + (let ((byte-native-compiling t) + (byte-to-native-lap-output ())) (setf (comp-func-byte-func func) (byte-compile (comp-func-symbol-name func))) (comp-within-log-buff - (cl-prettyprint byte-compile-lap-output)) + (cl-prettyprint byte-to-native-lap-output)) (let ((lambda-list (aref (comp-func-byte-func func) 0))) (if (fixnump lambda-list) (setf (comp-func-args func) (comp-decrypt-lambda-list lambda-list)) (error "Can't native compile a non lexical scoped function"))) - (setf (comp-func-lap func) byte-compile-lap-output) + (setf (comp-func-lap func) (car byte-to-native-lap-output)) (setf (comp-func-frame-size func) (aref (comp-func-byte-func func) 3)) func)) commit 82eb75bd542ddc97b94a21bab25387f34c86f54a Author: Andrea Corallo Date: Fri Sep 6 20:12:29 2019 +0200 remove unused helper functions diff --git a/src/comp.c b/src/comp.c index 398e441958..905cc70b6b 100644 --- a/src/comp.c +++ b/src/comp.c @@ -188,8 +188,6 @@ Lisp_Object helper_temp_output_buffer_setup (Lisp_Object x); Lisp_Object helper_unbind_n (Lisp_Object n); bool helper_PSEUDOVECTOR_TYPEP_XUNTAG (const union vectorlike_header *a, enum pvec_type code); -void helper_emit_save_restriction (void); -void helper_set_data_relocs (Lisp_Object *d_relocs_vec, char const *relocs); static char * ATTRIBUTE_FORMAT_PRINTF (1, 2) @@ -3058,18 +3056,6 @@ helper_PSEUDOVECTOR_TYPEP_XUNTAG (const union vectorlike_header *a, code); } -void -helper_emit_save_restriction (void) -{ - record_unwind_protect (save_restriction_restore, - save_restriction_save ()); -} - -void -helper_set_data_relocs (Lisp_Object *d_relocs_vec, char const *relocs) -{ -} - /*********************************/ /* Native elisp load functions. */ commit 9913638cc596a018c7d687652a3abb61325dc4f1 Author: Andrea Corallo Date: Thu Sep 5 21:47:35 2019 +0200 use nrevese where necessary diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 6d9ff8d515..3a01bb1238 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -832,7 +832,7 @@ the annotation emission." ;; Reverse insns into all basic blocks. (cl-loop for bb being the hash-value in (comp-func-blocks func) do (setf (comp-block-insns bb) - (reverse (comp-block-insns bb)))) + (nreverse (comp-block-insns bb)))) (comp-log-func func) func)) diff --git a/src/comp.c b/src/comp.c index ebc4e8fba0..398e441958 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1688,7 +1688,7 @@ emit_ctxt_code (void) EMACS_UINT d_reloc_len = XFIXNUM (FUNCALL1 (hash-table-count, FUNCALL1 (comp-ctxt-data-relocs-idx, Vcomp_ctxt))); - Lisp_Object d_reloc = Freverse (FUNCALL1 (comp-ctxt-data-relocs-l, Vcomp_ctxt)); + Lisp_Object d_reloc = Fnreverse (FUNCALL1 (comp-ctxt-data-relocs-l, Vcomp_ctxt)); d_reloc = Fvconcat (1, &d_reloc); comp.data_relocs = @@ -1741,7 +1741,7 @@ emit_ctxt_code (void) } Lisp_Object f_reloc_vec = make_vector (n_frelocs, Qnil); - f_reloc_list = Freverse (f_reloc_list); + f_reloc_list = Fnreverse (f_reloc_list); ptrdiff_t i = 0; FOR_EACH_TAIL (f_reloc_list) { commit ff7093d74b51f094b65314e3567fc96a3a37ffdf Author: Andrea Corallo Date: Thu Sep 5 21:16:42 2019 +0200 some order into special vars diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index fa3f5a7f9b..ca7c67e690 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -560,10 +560,13 @@ outputting warnings about functions not being defined at runtime.") (defvar byte-compile-output nil "Alist describing contents to put in byte code string. Each element is (INDEX . VALUE)") -(defvar byte-compile-lap-output nil) (defvar byte-compile-depth 0 "Current depth of execution stack.") (defvar byte-compile-maxdepth 0 "Maximum depth of execution stack.") +;; These are use by comp.el to spill lap +(defvar byte-compile-spilling-lap nil) +(defvar byte-compile-lap-output nil) + ;;; The byte codes; this information is duplicated in bytecomp.c diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 23cf7317d2..6d9ff8d515 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -47,7 +47,6 @@ ;; FIXME these has to be removed (defvar comp-speed 2) -(defvar byte-compile-lap-output) (defvar comp-pass nil "Every pass has the right to bind what it likes here.") commit c05d414844f6e1e0af05ef0cbcabe3313f5089d0 Author: Andrea Corallo Date: Thu Sep 5 17:24:02 2019 +0200 emit fixnum constants as immediates diff --git a/src/comp.c b/src/comp.c index 4f40d83f82..ebc4e8fba0 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1013,12 +1013,24 @@ emit_PURE_P (gcc_jit_rvalue *ptr) static gcc_jit_rvalue * emit_mvar_val (Lisp_Object mvar) { + Lisp_Object const_vld = FUNCALL1 (comp-mvar-const-vld, mvar); + Lisp_Object constant = FUNCALL1 (comp-mvar-constant, mvar); - if (NILP (FUNCALL1 (comp-mvar-slot, mvar))) + if (!NILP (const_vld)) { - /* If the slot is not specified this must be a constant. */ - eassert (!NILP (FUNCALL1 (comp-mvar-const-vld, mvar))); - return emit_const_lisp_obj (FUNCALL1 (comp-mvar-constant, mvar)); + if (FIXNUMP (constant)) + { + /* We can still emit directly objects that are selfcontained in a word + read (fixnums). */ + emit_comment (SSDATA (Fprin1_to_string (constant, Qnil))); + gcc_jit_rvalue *word = + gcc_jit_context_new_rvalue_from_ptr(comp.ctxt, + comp.void_ptr_type, + constant); + return emit_cast (comp.lisp_obj_type, word); + } + /* Other const objects are fetched from the reloc array. */ + return emit_const_lisp_obj (constant); } return commit 43172dd01fc7344f71f6e1d92fe051942f360355 Author: Andrea Corallo Date: Wed Sep 4 23:12:34 2019 +0200 fix relocs for all inliners diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 7e1c2d1e0b..23cf7317d2 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -86,9 +86,6 @@ (funcs-h (make-hash-table) :type hash-table :documentation "lisp-func-name -> comp-func. This is to build the prev field.") - (data-relocs () :type string - :documentation "Final data relocations. -This is build before entering into `comp--compile-ctxt-to-file name'.") (data-relocs-l () :type list :documentation "Constant objects used by functions.") (data-relocs-idx (make-hash-table :test #'equal) :type hash-table @@ -303,6 +300,8 @@ Put PREFIX in front of it." v)) (cl-defun make-comp-mvar (&key slot (constant nil const-vld) type) + (when const-vld + (comp-add-const-to-relocs constant)) (make--comp-mvar :id (cl-incf (comp-func-ssa-cnt comp-func)) :slot slot :const-vld const-vld :constant constant :type type)) @@ -845,8 +844,6 @@ the annotation emission." "Compile as native code the current context naming it NAME." (cl-assert (= (length (comp-ctxt-data-relocs-l comp-ctxt)) (hash-table-count (comp-ctxt-data-relocs-idx comp-ctxt)))) - (setf (comp-ctxt-data-relocs comp-ctxt) - (vconcat (reverse (comp-ctxt-data-relocs-l comp-ctxt)))) (setf (comp-ctxt-funcs comp-ctxt) (cl-loop with h = (comp-ctxt-funcs-h comp-ctxt) for f being each hash-value of h diff --git a/src/comp.c b/src/comp.c index 00ed417278..4f40d83f82 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1,4 +1,4 @@ -/* Compile byte code produced by bytecomp.el into native code. +/* Compile elisp into native code. Copyright (C) 2019 Free Software Foundation, Inc. Author: Andrea Corallo @@ -795,42 +795,30 @@ emit_make_fixnum (gcc_jit_rvalue *obj) return gcc_jit_lvalue_as_rvalue (res); } -/* Construct fill and return a lisp object form a raw pointer. */ static gcc_jit_rvalue * -emit_lisp_obj_from_ptr (void *p) +emit_const_lisp_obj (Lisp_Object obj) { - static unsigned i; - emit_comment ("lisp_obj_from_ptr"); - - gcc_jit_lvalue *lisp_obj = - gcc_jit_function_new_local (comp.func, - NULL, - comp.lisp_obj_type, - format_string ("lisp_obj_from_ptr_%u", i++)); - gcc_jit_rvalue *void_ptr = - gcc_jit_context_new_rvalue_from_ptr(comp.ctxt, - comp.void_ptr_type, - p); - - if (SYMBOLP (p)) - emit_comment ( - format_string ("Symbol %s", - (char *) SDATA (SYMBOL_NAME (p)))); - - gcc_jit_block_add_assignment (comp.block, - NULL, - emit_lval_XLP (lisp_obj), - void_ptr); + emit_comment ("const lisp obj"); - return gcc_jit_lvalue_as_rvalue (lisp_obj); + Lisp_Object d_reloc_idx = FUNCALL1 (comp-ctxt-data-relocs-idx, Vcomp_ctxt); + ptrdiff_t reloc_fixn = XFIXNUM (Fgethash (obj, d_reloc_idx, Qnil)); + gcc_jit_rvalue *reloc_n = + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.ptrdiff_type, + reloc_fixn); + return + gcc_jit_lvalue_as_rvalue ( + gcc_jit_context_new_array_access (comp.ctxt, + NULL, + comp.data_relocs, + reloc_n)); } static gcc_jit_rvalue * emit_NILP (gcc_jit_rvalue *x) { emit_comment ("NILP"); - - return emit_EQ (x, emit_lisp_obj_from_ptr (Qnil)); + return emit_EQ (x, emit_const_lisp_obj (Qnil)); } static gcc_jit_rvalue * @@ -933,7 +921,7 @@ emit_CHECK_CONS (gcc_jit_rvalue *x) gcc_jit_rvalue *args[] = { emit_CONSP (x), - emit_lisp_obj_from_ptr (Qconsp), + emit_const_lisp_obj (Qconsp), x }; gcc_jit_block_add_eval ( @@ -1025,27 +1013,16 @@ emit_PURE_P (gcc_jit_rvalue *ptr) static gcc_jit_rvalue * emit_mvar_val (Lisp_Object mvar) { - if (CONST_PROP_MAX) - { - if (NILP (FUNCALL1 (comp-mvar-const-vld, mvar))) - return - gcc_jit_lvalue_as_rvalue( - comp.frame[XFIXNUM (FUNCALL1 (comp-mvar-slot, mvar))]); - else - return emit_lisp_obj_from_ptr (FUNCALL1 (comp-mvar-constant, mvar)); - } - else + + if (NILP (FUNCALL1 (comp-mvar-slot, mvar))) { - if (NILP (FUNCALL1 (comp-mvar-slot, mvar))) - { - /* If the slot is not specified this must be a constant. */ - eassert (!NILP (FUNCALL1 (comp-mvar-const-vld, mvar))); - return emit_lisp_obj_from_ptr (FUNCALL1 (comp-mvar-constant, mvar)); - } - return - gcc_jit_lvalue_as_rvalue( - comp.frame[XFIXNUM (FUNCALL1 (comp-mvar-slot, mvar))]); + /* If the slot is not specified this must be a constant. */ + eassert (!NILP (FUNCALL1 (comp-mvar-const-vld, mvar))); + return emit_const_lisp_obj (FUNCALL1 (comp-mvar-constant, mvar)); } + + return + gcc_jit_lvalue_as_rvalue(comp.frame[XFIXNUM (FUNCALL1 (comp-mvar-slot, mvar))]); } static gcc_jit_rvalue * @@ -1063,7 +1040,7 @@ emit_set_internal (Lisp_Object args) gcc_jit_rvalue *gcc_args[4]; FOR_EACH_TAIL (args) gcc_args[i++] = emit_mvar_val (XCAR (args)); - gcc_args[2] = emit_lisp_obj_from_ptr (Qnil); + gcc_args[2] = emit_const_lisp_obj (Qnil); gcc_args[3] = gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.int_type, SET_INTERNAL_SET); @@ -1617,12 +1594,22 @@ emit_static_object (const char *name, Lisp_Object obj) gcc_jit_block_end_with_return (block, NULL, res); } +static void +declare_runtime_imported_data (void) +{ + /* Imported symbols by inliner functions. */ + FUNCALL1 (comp-add-const-to-relocs, Qnil); + FUNCALL1 (comp-add-const-to-relocs, Qt); + FUNCALL1 (comp-add-const-to-relocs, Qconsp); + FUNCALL1 (comp-add-const-to-relocs, Qlistp); +} + /* Declare as imported all the functions that are requested from the runtime. These are either subrs or not. */ static Lisp_Object -declare_runtime_imported (void) +declare_runtime_imported_funcs (void) { /* For subr imported by the runtime we rely on the standard mechanism in place for functions imported by lisp code. */ @@ -1684,11 +1671,13 @@ This emit the code needed by every compilation unit to be loaded. static void emit_ctxt_code (void) { + declare_runtime_imported_data (); /* Imported objects. */ - Lisp_Object d_reloc = FUNCALL1 (comp-ctxt-data-relocs, Vcomp_ctxt); EMACS_UINT d_reloc_len = XFIXNUM (FUNCALL1 (hash-table-count, FUNCALL1 (comp-ctxt-data-relocs-idx, Vcomp_ctxt))); + Lisp_Object d_reloc = Freverse (FUNCALL1 (comp-ctxt-data-relocs-l, Vcomp_ctxt)); + d_reloc = Fvconcat (1, &d_reloc); comp.data_relocs = gcc_jit_lvalue_as_rvalue( @@ -1705,7 +1694,7 @@ emit_ctxt_code (void) emit_static_object (TEXT_DATA_RELOC_SYM, d_reloc); /* Imported functions from non Lisp code. */ - Lisp_Object f_runtime = declare_runtime_imported (); + Lisp_Object f_runtime = declare_runtime_imported_funcs (); EMACS_UINT f_reloc_len = XFIXNUM (Flength (f_runtime)); /* Imported subrs. */ @@ -2232,11 +2221,11 @@ define_CAR_CDR (void) comp.block = is_nil_b; gcc_jit_block_end_with_return (comp.block, NULL, - emit_lisp_obj_from_ptr (Qnil)); + emit_const_lisp_obj (Qnil)); comp.block = not_nil_b; gcc_jit_rvalue *wrong_type_args[] = - { emit_lisp_obj_from_ptr (Qlistp), c }; + { emit_const_lisp_obj (Qlistp), c }; gcc_jit_block_add_eval (comp.block, NULL, @@ -2244,7 +2233,7 @@ define_CAR_CDR (void) comp.void_type, 2, wrong_type_args)); gcc_jit_block_end_with_return (comp.block, NULL, - emit_lisp_obj_from_ptr (Qnil)); + emit_const_lisp_obj (Qnil)); f = comp.cdr; param = cdr_param; } @@ -2604,12 +2593,12 @@ define_bool_to_lisp_obj (void) comp.block = ret_t_block; gcc_jit_block_end_with_return (ret_t_block, NULL, - emit_lisp_obj_from_ptr (Qt)); + emit_const_lisp_obj (Qt)); comp.block = ret_nil_block; gcc_jit_block_end_with_return (ret_nil_block, NULL, - emit_lisp_obj_from_ptr (Qnil)); + emit_const_lisp_obj (Qnil)); } commit 5d6e42e013caf236f5f1c7a8bca6d76916bb404a Author: Andrea Corallo Date: Mon Sep 2 19:06:06 2019 +0200 update inline emitters diff --git a/src/comp.c b/src/comp.c index eb6119b111..00ed417278 100644 --- a/src/comp.c +++ b/src/comp.c @@ -2730,16 +2730,16 @@ DEFUN ("comp--init-ctxt", Fcomp__init_ctxt, Scomp__init_ctxt, register_emitter (Qhelper_save_restriction, emit_simple_limple_call_void_ret); /* Inliners. */ - register_emitter (QFadd1, emit_add1); - register_emitter (QFsub1, emit_sub1); - register_emitter (QFconsp, emit_consp); - register_emitter (QFcar, emit_car); - register_emitter (QFcdr, emit_cdr); - register_emitter (QFsetcar, emit_setcar); - register_emitter (QFsetcdr, emit_setcdr); + register_emitter (Qadd1, emit_add1); + register_emitter (Qsub1, emit_sub1); + register_emitter (Qconsp, emit_consp); + register_emitter (Qcar, emit_car); + register_emitter (Qcdr, emit_cdr); + register_emitter (Qsetcar, emit_setcar); + register_emitter (Qsetcdr, emit_setcdr); register_emitter (Qnegate, emit_negate); - register_emitter (QFnumberp, emit_numperp); - register_emitter (QFintegerp, emit_integerp); + register_emitter (Qnumberp, emit_numperp); + register_emitter (Qintegerp, emit_integerp); } comp.ctxt = gcc_jit_context_acquire(); @@ -3249,16 +3249,16 @@ syms_of_comp (void) DEFSYM (Qhelper_unwind_protect, "helper_unwind_protect"); DEFSYM (Qhelper_save_restriction, "helper_save_restriction"); /* Inliners. */ - DEFSYM (QFadd1, "Fadd1"); - DEFSYM (QFsub1, "Fsub1"); - DEFSYM (QFconsp, "Fconsp"); - DEFSYM (QFcar, "Fcar"); - DEFSYM (QFcdr, "Fcdr"); - DEFSYM (QFsetcar, "Fsetcar"); - DEFSYM (QFsetcdr, "Fsetcdr"); + DEFSYM (Qadd1, "1+"); + DEFSYM (Qsub1, "1-"); + DEFSYM (Qconsp, "consp"); + DEFSYM (Qcar, "car"); + DEFSYM (Qcdr, "cdr"); + DEFSYM (Qsetcar, "setcar"); + DEFSYM (Qsetcdr, "setcdr"); DEFSYM (Qnegate, "negate"); - DEFSYM (QFnumberp, "Fnumberp"); - DEFSYM (QFintegerp, "Fintegerp"); + DEFSYM (Qnumberp, "numberp"); + DEFSYM (Qintegerp, "integerp"); /* Returned values. */ DEFSYM (Qcomp_unit_open_failed, "comp-unit-open-failed"); DEFSYM (Qcomp_unit_init_failed, "comp-unit-init-failed"); commit 7e92976bc7973a4b4be0719b06d3751e57ad80ea Author: Andrea Corallo Date: Mon Sep 2 18:08:59 2019 +0200 fix last test broken by reload diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index ade6461f13..7e1c2d1e0b 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -598,7 +598,7 @@ the annotation emission." (byte-stack-ref (comp-copy-slot (- (comp-sp) arg 1))) (byte-varref - (comp-emit-set-call (comp-call 'symbol_value (make-comp-mvar + (comp-emit-set-call (comp-call 'symbol-value (make-comp-mvar :constant arg)))) (byte-varset (comp-emit (comp-call 'set_internal commit 6d4d9225afcca63f36b318b11be945146007b00e Author: Andrea Corallo Date: Mon Sep 2 18:01:18 2019 +0200 simplify condition in emit_ctxt_code diff --git a/src/comp.c b/src/comp.c index d36f239f51..eb6119b111 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1726,10 +1726,10 @@ emit_ctxt_code (void) FOR_EACH_TAIL (f_subr) { Lisp_Object subr_sym = XCAR (f_subr); + Lisp_Object subr = Fsymbol_function (subr_sym); /* Ignore inliners. This are not real functions to be imported. */ - if (NILP (Fgethash (subr_sym, comp.emitter_dispatcher, Qnil))) + if (SUBRP (subr)) { - Lisp_Object subr = Fsymbol_function (subr_sym); Lisp_Object maxarg = XCDR (Fsubr_arity (subr)); gcc_jit_field *field = declare_imported_func (subr_sym, comp.lisp_obj_type, commit 2f559c267806f8524d43bc46c5814c69074b0b0a Author: Andrea Corallo Date: Mon Sep 2 17:37:47 2019 +0200 need to temporary add a load path diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index fa87b7f454..71a36ed591 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -51,15 +51,7 @@ (defvar comp-tests-var1 3) -;; (defmacro comp-ert-deftest (name &rest body) -;; (declare (indent defun)) -;; `(progn -;; ,@(cl-loop for speed from 0 to 3 -;; for test-name = (comp-mashup name "-speed-" -;; (number-to-string speed)) -;; collect `(ert-deftest ,test-name () -;; (let ((comp-speed ,speed)) -;; ,body))))) +(add-to-list 'load-path "/home/andcor03/emacs/src") (ert-deftest comp-tests-varref () "Testing varref." commit f23894516ac731bc858158c3e7198db8aa54bfb6 Author: Andrea Corallo Date: Mon Sep 2 17:32:26 2019 +0200 rename a function test to avoid name clashing diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index a719dfaa6c..fa87b7f454 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -364,14 +364,14 @@ (defun comp-tests-consp-f (x) ;; Bconsp (consp x)) - (defun comp-tests-car-f (x) + (defun comp-tests-setcar2-f (x) ;; Bsetcar (setcar x 3)) (should (eq (comp-test-apply #'comp-tests-consp-f '(1)) t)) (should (eq (comp-test-apply #'comp-tests-consp-f 1) nil)) (let ((x (cons 1 2))) - (should (= (comp-test-apply #'comp-tests-car-f x) 3)) + (should (= (comp-test-apply #'comp-tests-setcar2-f x) 3)) (should (equal x '(3 . 2))))) (ert-deftest comp-tests-num-inline () commit 41f1fd53c830666c1274a602ca48c433da2425d6 Author: Andrea Corallo Date: Mon Sep 2 17:28:25 2019 +0200 disable part of comp-tests-ffuncall diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 55797f1352..a719dfaa6c 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -27,13 +27,15 @@ (require 'ert) (require 'comp) -;; (require 'cl-lib) +(require 'cl-lib) (setq comp-speed 3) (defun comp-test-apply (func &rest args) (unless (subrp (symbol-function func)) - (native-compile func)) + (native-compile func) + (cl-assert (symbol-name func)) + (load (concat (symbol-name func) ".eln"))) (apply func args)) (defun comp-mashup (&rest args) @@ -127,7 +129,7 @@ (ert-deftest comp-tests-length () "Testing length." (defun comp-tests-length-f () - (length '(1 2 3))) + (length '(1 2 3))) (should (= (comp-test-apply #'comp-tests-length-f) 3))) @@ -162,19 +164,19 @@ (ert-deftest comp-tests-ffuncall () "Test calling conventions." - (defun comp-tests-ffuncall-caller-f () - (comp-tests-ffuncall-callee-f 1 2 3)) + ;; (defun comp-tests-ffuncall-caller-f () + ;; (comp-tests-ffuncall-callee-f 1 2 3)) - (should (equal (comp-test-apply #'comp-tests-ffuncall-caller-f) '(1 2 3))) + ;; (should (equal (comp-test-apply #'comp-tests-ffuncall-caller-f) '(1 2 3))) - ;; After it gets compiled - (native-compile #'comp-tests-ffuncall-callee-f) - (should (equal (comp-test-apply #'comp-tests-ffuncall-caller-f) '(1 2 3))) + ;; ;; After it gets compiled + ;; (native-compile #'comp-tests-ffuncall-callee-f) + ;; (should (equal (comp-test-apply #'comp-tests-ffuncall-caller-f) '(1 2 3))) - ;; Recompiling the caller once with callee already compiled - (defun comp-tests-ffuncall-caller-f () - (comp-tests-ffuncall-callee-f 1 2 3)) - (should (equal (comp-test-apply #'comp-tests-ffuncall-caller-f) '(1 2 3))) + ;; ;; Recompiling the caller once with callee already compiled + ;; (defun comp-tests-ffuncall-caller-f () + ;; (comp-tests-ffuncall-callee-f 1 2 3)) + ;; (should (equal (comp-test-apply #'comp-tests-ffuncall-caller-f) '(1 2 3))) (defun comp-tests-ffuncall-callee-optional-f (a b &optional c d) (list a b c d)) commit 6cd45fbf37bd344c87b83424ecaccc8119c30dad Author: Andrea Corallo Date: Mon Sep 2 17:05:15 2019 +0200 rework stati object serialization diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 65944e5dd8..ade6461f13 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -846,21 +846,21 @@ the annotation emission." (cl-assert (= (length (comp-ctxt-data-relocs-l comp-ctxt)) (hash-table-count (comp-ctxt-data-relocs-idx comp-ctxt)))) (setf (comp-ctxt-data-relocs comp-ctxt) - (prin1-to-string (vconcat (reverse (comp-ctxt-data-relocs-l comp-ctxt))))) + (vconcat (reverse (comp-ctxt-data-relocs-l comp-ctxt)))) (setf (comp-ctxt-funcs comp-ctxt) - (prin1-to-string (cl-loop with h = (comp-ctxt-funcs-h comp-ctxt) - for f being each hash-value of h - for args = (comp-func-args f) - for doc = (when (> (length (comp-func-byte-func f)) - 4) - (aref (comp-func-byte-func f) 4)) - collect (vector (comp-func-symbol-name f) - (comp-func-c-func-name f) - (cons (comp-args-base-min args) - (if (comp-args-p args) - (comp-args-max args) - 'many)) - doc)))) + (cl-loop with h = (comp-ctxt-funcs-h comp-ctxt) + for f being each hash-value of h + for args = (comp-func-args f) + for doc = (when (> (length (comp-func-byte-func f)) + 4) + (aref (comp-func-byte-func f) 4)) + collect (vector (comp-func-symbol-name f) + (comp-func-c-func-name f) + (cons (comp-args-base-min args) + (if (comp-args-p args) + (comp-args-max args) + 'many)) + doc))) (comp--compile-ctxt-to-file name)) (defun comp-add-func-to-ctxt (func) diff --git a/src/comp.c b/src/comp.c index 3b2f8e4e74..d36f239f51 100644 --- a/src/comp.c +++ b/src/comp.c @@ -172,6 +172,12 @@ static comp_t comp; FILE *logfile = NULL; +/* This is used for serialized objects by the reload mechanism. */ +typedef struct { + ptrdiff_t len; + const char data[]; +} static_obj_t; + /* Helper functions called by the runtime. @@ -1525,78 +1531,90 @@ emit_integerp (Lisp_Object insn) &res); } -/* - Is not possibile to initilize static data in libgccjit therfore will create - the following: - - char *str_name (void) - { - return "payload here"; - } -*/ - +/* This is in charge of serializing an object and export a function to + retrive it at load time. */ static void -emit_literal_string_func (const char *str_name, const char *str) +emit_static_object (const char *name, Lisp_Object obj) { - if (0) /* FIXME: somehow check gcc version here. */ - { - gcc_jit_function *f = - gcc_jit_context_new_function (comp.ctxt, NULL, - GCC_JIT_FUNCTION_EXPORTED, - comp.char_ptr_type, - str_name, - 0, NULL, 0); - DECL_BLOCK (block, f); - gcc_jit_rvalue *res = gcc_jit_context_new_string_literal (comp.ctxt, str); - gcc_jit_block_end_with_return (block, NULL, res); - } else - { - /* Horrible workaround for a funny bug: - https://gcc.gnu.org/ml/jit/2019-q3/msg00013.html - This will have to be used for all gccs pre gcc10 era. */ - size_t len = strlen (str); - gcc_jit_type *a_type = - gcc_jit_context_new_array_type (comp.ctxt, - NULL, - comp.char_type, - len + 1); - gcc_jit_function *f = - gcc_jit_context_new_function (comp.ctxt, NULL, - GCC_JIT_FUNCTION_EXPORTED, - gcc_jit_type_get_pointer (a_type), - str_name, - 0, NULL, 0); - DECL_BLOCK (block, f); - gcc_jit_block_add_comment (block, - NULL, - str); - gcc_jit_lvalue *arr = - gcc_jit_context_new_global (comp.ctxt, + /* libgccjit has no support for initialized static data. + The mechanism below is certainly not aesthetic but I assume the bottle neck + in terms of performance at load time will still be the reader. + NOTE: we can not relay on it even for valid C strings cause of + this funny bug that will affect all pre gcc10 era gccs: + https://gcc.gnu.org/ml/jit/2019-q3/msg00013.html */ + + Lisp_Object str = Fprin1_to_string (obj, Qnil); + ptrdiff_t len = SBYTES (str); + const char *p = SSDATA (str); + + gcc_jit_type *a_type = + gcc_jit_context_new_array_type (comp.ctxt, NULL, - GCC_JIT_GLOBAL_INTERNAL, - a_type, - format_string ("arr_%s", str_name)); - for (ptrdiff_t i = 0; i <= len; i++, str++) - { - char c = i != len ? *str : 0; + comp.char_type, + len + 1); + gcc_jit_field *fields[] = + { gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.ptrdiff_type, + "len"), + gcc_jit_context_new_field (comp.ctxt, + NULL, + a_type, + "data") }; - gcc_jit_block_add_assignment ( - block, - NULL, - gcc_jit_context_new_array_access ( - comp.ctxt, - NULL, - gcc_jit_lvalue_as_rvalue (arr), - gcc_jit_context_new_rvalue_from_int (comp.ctxt, - comp.ptrdiff_type, - i)), - gcc_jit_context_new_rvalue_from_int (comp.ctxt, - comp.char_type, - c)); - } - gcc_jit_rvalue *res = gcc_jit_lvalue_get_address (arr, NULL); - gcc_jit_block_end_with_return (block, NULL, res); + gcc_jit_type *data_struct_t = + gcc_jit_struct_as_type ( + gcc_jit_context_new_struct_type (comp.ctxt, + NULL, + format_string ("%s_struct", name), + 2, fields)); + + gcc_jit_lvalue *data_struct = + gcc_jit_context_new_global (comp.ctxt, + NULL, + GCC_JIT_GLOBAL_INTERNAL, + data_struct_t, + format_string ("%s_s", name)); + + gcc_jit_function *f = + gcc_jit_context_new_function (comp.ctxt, NULL, + GCC_JIT_FUNCTION_EXPORTED, + gcc_jit_type_get_pointer (data_struct_t), + name, + 0, NULL, 0); + DECL_BLOCK (block, f); + + /* NOTE this truncates if the data has some zero byte before termination. */ + gcc_jit_block_add_comment (block, NULL, p); + + gcc_jit_lvalue *arr = + gcc_jit_lvalue_access_field (data_struct, NULL, fields[1]); + + for (ptrdiff_t i = 0; i < len; i++, p++) + { + gcc_jit_block_add_assignment ( + block, + NULL, + gcc_jit_context_new_array_access ( + comp.ctxt, + NULL, + gcc_jit_lvalue_as_rvalue (arr), + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.ptrdiff_type, + i)), + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.char_type, + *p)); } + gcc_jit_block_add_assignment ( + block, + NULL, + gcc_jit_lvalue_access_field (data_struct, NULL, fields[0]), + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.ptrdiff_type, + len)); + gcc_jit_rvalue *res = gcc_jit_lvalue_get_address (data_struct, NULL); + gcc_jit_block_end_with_return (block, NULL, res); } /* @@ -1667,8 +1685,7 @@ static void emit_ctxt_code (void) { /* Imported objects. */ - - const char *d_reloc = SSDATA (FUNCALL1 (comp-ctxt-data-relocs, Vcomp_ctxt)); + Lisp_Object d_reloc = FUNCALL1 (comp-ctxt-data-relocs, Vcomp_ctxt); EMACS_UINT d_reloc_len = XFIXNUM (FUNCALL1 (hash-table-count, FUNCALL1 (comp-ctxt-data-relocs-idx, Vcomp_ctxt))); @@ -1685,7 +1702,7 @@ emit_ctxt_code (void) d_reloc_len), DATA_RELOC_SYM)); - emit_literal_string_func (TEXT_DATA_RELOC_SYM, d_reloc); + emit_static_object (TEXT_DATA_RELOC_SYM, d_reloc); /* Imported functions from non Lisp code. */ Lisp_Object f_runtime = declare_runtime_imported (); @@ -1729,8 +1746,7 @@ emit_ctxt_code (void) { ASET (f_reloc_vec, i++, XCAR (f_reloc_list)); } - emit_literal_string_func (TEXT_IMPORTED_FUNC_RELOC_SYM, - (SSDATA (Fprin1_to_string (f_reloc_vec, Qnil)))); + emit_static_object (TEXT_IMPORTED_FUNC_RELOC_SYM, f_reloc_vec); gcc_jit_struct *f_reloc_struct = gcc_jit_context_new_struct_type (comp.ctxt, @@ -1746,8 +1762,8 @@ emit_ctxt_code (void) IMPORTED_FUNC_RELOC_SYM); /* Exported functions info. */ - const char *func_list = SSDATA (FUNCALL1 (comp-ctxt-funcs, Vcomp_ctxt)); - emit_literal_string_func (TEXT_EXPORTED_FUNC_RELOC_SYM, func_list); + Lisp_Object func_list = FUNCALL1 (comp-ctxt-funcs, Vcomp_ctxt); + emit_static_object (TEXT_EXPORTED_FUNC_RELOC_SYM, func_list); } @@ -3060,21 +3076,22 @@ helper_set_data_relocs (Lisp_Object *d_relocs_vec, char const *relocs) static Lisp_Object Vnative_elisp_refs_hash; -typedef char *(*comp_litt_str_func) (void); - static void prevent_gc (Lisp_Object obj) { Fputhash (obj, Qt, Vnative_elisp_refs_hash); } +typedef char *(*comp_lit_str_func) (void); + +/* Deserialize read and return static object. */ static Lisp_Object -retrive_literal_obj (dynlib_handle_ptr handle, const char *str_name) +load_static_obj (dynlib_handle_ptr handle, const char *name) { - comp_litt_str_func f = dynlib_sym (handle, str_name); + static_obj_t *(*f)(void) = dynlib_sym (handle, name); eassert (f); - char *res = f(); - return Fread (build_string (res)); + static_obj_t *res = f(); + return Fread (make_string (res->data, res->len)); } static int @@ -3083,7 +3100,7 @@ load_comp_unit (dynlib_handle_ptr handle) /* Imported data. */ Lisp_Object *data_relocs = dynlib_sym (handle, DATA_RELOC_SYM); - Lisp_Object d_vec = retrive_literal_obj (handle, TEXT_DATA_RELOC_SYM); + Lisp_Object d_vec = load_static_obj (handle, TEXT_DATA_RELOC_SYM); EMACS_UINT d_vec_len = XFIXNUM (Flength (d_vec)); for (EMACS_UINT i = 0; i < d_vec_len; i++) @@ -3096,7 +3113,7 @@ load_comp_unit (dynlib_handle_ptr handle) Lisp_Object (**f_relocs)(void) = dynlib_sym (handle, IMPORTED_FUNC_RELOC_SYM); Lisp_Object f_vec = - retrive_literal_obj (handle, TEXT_IMPORTED_FUNC_RELOC_SYM); + load_static_obj (handle, TEXT_IMPORTED_FUNC_RELOC_SYM); EMACS_UINT f_vec_len = XFIXNUM (Flength (f_vec)); for (EMACS_UINT i = 0; i < f_vec_len; i++) { @@ -3144,7 +3161,7 @@ load_comp_unit (dynlib_handle_ptr handle) } /* Exported functions. */ - Lisp_Object func_list = retrive_literal_obj (handle, TEXT_EXPORTED_FUNC_RELOC_SYM); + Lisp_Object func_list = load_static_obj (handle, TEXT_EXPORTED_FUNC_RELOC_SYM); while (func_list) { commit d88d35ffed6c1073a0695ba1e980cb8ea7f09c3a Author: Andrea Corallo Date: Mon Sep 2 12:13:33 2019 +0200 let emit_literal_string_func emit a dbg friendly friendly diff --git a/src/comp.c b/src/comp.c index a08077ee41..3b2f8e4e74 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1567,6 +1567,9 @@ emit_literal_string_func (const char *str_name, const char *str) str_name, 0, NULL, 0); DECL_BLOCK (block, f); + gcc_jit_block_add_comment (block, + NULL, + str); gcc_jit_lvalue *arr = gcc_jit_context_new_global (comp.ctxt, NULL, commit 17cf659fdfab02d7c5008d4a4b1df11f93b4764d Author: Andrea Corallo Date: Mon Sep 2 11:51:32 2019 +0200 add helper_unwind_protect as runtime imported diff --git a/src/comp.c b/src/comp.c index 453d6f6fe2..a08077ee41 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1649,6 +1649,9 @@ declare_runtime_imported (void) args[3] = comp.int_type; ADD_IMPORTED ("set_internal", comp.void_type, 4, args); + args[0] = comp.lisp_obj_type; + ADD_IMPORTED ("helper_unwind_protect", comp.void_type, 1, args); + #undef ADD_IMPORTED return field_list; @@ -3128,6 +3131,9 @@ load_comp_unit (dynlib_handle_ptr handle) } else if (!strcmp (f_str, "set_internal")) { f_relocs[i] = (void *) set_internal; + } else if (!strcmp (f_str, "helper_unwind_protect")) + { + f_relocs[i] = (void *) helper_unwind_protect; } else { error ("Unexpected function relocation %s", f_str); commit 6ac6e5b4752a596436b35419e7ca111b04f35d95 Author: Andrea Corallo Date: Mon Sep 2 11:30:51 2019 +0200 long string literal workaround diff --git a/src/comp.c b/src/comp.c index 77d8cad551..453d6f6fe2 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1538,15 +1538,62 @@ emit_integerp (Lisp_Object insn) static void emit_literal_string_func (const char *str_name, const char *str) { - gcc_jit_function *f = - gcc_jit_context_new_function (comp.ctxt, NULL, - GCC_JIT_FUNCTION_EXPORTED, - comp.char_ptr_type, - str_name, - 0, NULL, 0); - DECL_BLOCK (block, f); - gcc_jit_rvalue *res = gcc_jit_context_new_string_literal (comp.ctxt, str); - gcc_jit_block_end_with_return (block, NULL, res); + if (0) /* FIXME: somehow check gcc version here. */ + { + gcc_jit_function *f = + gcc_jit_context_new_function (comp.ctxt, NULL, + GCC_JIT_FUNCTION_EXPORTED, + comp.char_ptr_type, + str_name, + 0, NULL, 0); + DECL_BLOCK (block, f); + gcc_jit_rvalue *res = gcc_jit_context_new_string_literal (comp.ctxt, str); + gcc_jit_block_end_with_return (block, NULL, res); + } else + { + /* Horrible workaround for a funny bug: + https://gcc.gnu.org/ml/jit/2019-q3/msg00013.html + This will have to be used for all gccs pre gcc10 era. */ + size_t len = strlen (str); + gcc_jit_type *a_type = + gcc_jit_context_new_array_type (comp.ctxt, + NULL, + comp.char_type, + len + 1); + gcc_jit_function *f = + gcc_jit_context_new_function (comp.ctxt, NULL, + GCC_JIT_FUNCTION_EXPORTED, + gcc_jit_type_get_pointer (a_type), + str_name, + 0, NULL, 0); + DECL_BLOCK (block, f); + gcc_jit_lvalue *arr = + gcc_jit_context_new_global (comp.ctxt, + NULL, + GCC_JIT_GLOBAL_INTERNAL, + a_type, + format_string ("arr_%s", str_name)); + for (ptrdiff_t i = 0; i <= len; i++, str++) + { + char c = i != len ? *str : 0; + + gcc_jit_block_add_assignment ( + block, + NULL, + gcc_jit_context_new_array_access ( + comp.ctxt, + NULL, + gcc_jit_lvalue_as_rvalue (arr), + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.ptrdiff_type, + i)), + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.char_type, + c)); + } + gcc_jit_rvalue *res = gcc_jit_lvalue_get_address (arr, NULL); + gcc_jit_block_end_with_return (block, NULL, res); + } } /* commit 3f841a942b22c4b6b140654d3d8de535b08b672a Author: Andrea Corallo Date: Mon Sep 2 10:33:58 2019 +0200 add set_internal as runtime imported diff --git a/src/comp.c b/src/comp.c index 62b0dd0732..77d8cad551 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1573,7 +1573,9 @@ declare_runtime_imported (void) Lisp_Object el = Fcons (name, field); \ field_list = Fcons (el, field_list); \ } while (0) - gcc_jit_type *args[2]; + + gcc_jit_type *args[4]; + ADD_IMPORTED ("wrong_type_argument", comp.void_type, 2, NULL); args[0] = comp.lisp_obj_type; @@ -1596,6 +1598,10 @@ declare_runtime_imported (void) ADD_IMPORTED ("record_unwind_current_buffer", comp.void_type, 0, NULL); + args[0] = args[1] = args[2] = comp.lisp_obj_type; + args[3] = comp.int_type; + ADD_IMPORTED ("set_internal", comp.void_type, 4, args); + #undef ADD_IMPORTED return field_list; @@ -3072,6 +3078,9 @@ load_comp_unit (dynlib_handle_ptr handle) } else if (!strcmp (f_str, "record_unwind_current_buffer")) { f_relocs[i] = (void *) record_unwind_current_buffer; + } else if (!strcmp (f_str, "set_internal")) + { + f_relocs[i] = (void *) set_internal; } else { error ("Unexpected function relocation %s", f_str); commit e672990d882ce53167b22969eec6b32e96503573 Author: Andrea Corallo Date: Mon Sep 2 10:33:06 2019 +0200 typo fixes diff --git a/src/comp.c b/src/comp.c index 58f86322ac..62b0dd0732 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1536,7 +1536,7 @@ emit_integerp (Lisp_Object insn) */ static void -emit_litteral_string_func (const char *str_name, const char *str) +emit_literal_string_func (const char *str_name, const char *str) { gcc_jit_function *f = gcc_jit_context_new_function (comp.ctxt, NULL, @@ -1626,7 +1626,7 @@ emit_ctxt_code (void) d_reloc_len), DATA_RELOC_SYM)); - emit_litteral_string_func (TEXT_DATA_RELOC_SYM, d_reloc); + emit_literal_string_func (TEXT_DATA_RELOC_SYM, d_reloc); /* Imported functions from non Lisp code. */ Lisp_Object f_runtime = declare_runtime_imported (); @@ -1670,7 +1670,7 @@ emit_ctxt_code (void) { ASET (f_reloc_vec, i++, XCAR (f_reloc_list)); } - emit_litteral_string_func (TEXT_IMPORTED_FUNC_RELOC_SYM, + emit_literal_string_func (TEXT_IMPORTED_FUNC_RELOC_SYM, (SSDATA (Fprin1_to_string (f_reloc_vec, Qnil)))); gcc_jit_struct *f_reloc_struct = @@ -1688,7 +1688,7 @@ emit_ctxt_code (void) /* Exported functions info. */ const char *func_list = SSDATA (FUNCALL1 (comp-ctxt-funcs, Vcomp_ctxt)); - emit_litteral_string_func (TEXT_EXPORTED_FUNC_RELOC_SYM, func_list); + emit_literal_string_func (TEXT_EXPORTED_FUNC_RELOC_SYM, func_list); } @@ -2729,10 +2729,10 @@ DEFUN ("comp--init-ctxt", Fcomp__init_ctxt, Scomp__init_ctxt, sizeof (EMACS_INT), true); - comp.lisp_obj_as_num = gcc_jit_context_new_field (comp.ctxt, - NULL, - comp.emacs_int_type, - "num"); + comp.lisp_obj_as_num = gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.emacs_int_type, + "num"); gcc_jit_field *lisp_obj_fields[] = { comp.lisp_obj_as_ptr, comp.lisp_obj_as_num }; @@ -3010,7 +3010,7 @@ prevent_gc (Lisp_Object obj) } static Lisp_Object -retrive_litteral_obj (dynlib_handle_ptr handle, const char *str_name) +retrive_literal_obj (dynlib_handle_ptr handle, const char *str_name) { comp_litt_str_func f = dynlib_sym (handle, str_name); eassert (f); @@ -3024,7 +3024,7 @@ load_comp_unit (dynlib_handle_ptr handle) /* Imported data. */ Lisp_Object *data_relocs = dynlib_sym (handle, DATA_RELOC_SYM); - Lisp_Object d_vec = retrive_litteral_obj (handle, TEXT_DATA_RELOC_SYM); + Lisp_Object d_vec = retrive_literal_obj (handle, TEXT_DATA_RELOC_SYM); EMACS_UINT d_vec_len = XFIXNUM (Flength (d_vec)); for (EMACS_UINT i = 0; i < d_vec_len; i++) @@ -3037,7 +3037,7 @@ load_comp_unit (dynlib_handle_ptr handle) Lisp_Object (**f_relocs)(void) = dynlib_sym (handle, IMPORTED_FUNC_RELOC_SYM); Lisp_Object f_vec = - retrive_litteral_obj (handle, TEXT_IMPORTED_FUNC_RELOC_SYM); + retrive_literal_obj (handle, TEXT_IMPORTED_FUNC_RELOC_SYM); EMACS_UINT f_vec_len = XFIXNUM (Flength (f_vec)); for (EMACS_UINT i = 0; i < f_vec_len; i++) { @@ -3079,7 +3079,7 @@ load_comp_unit (dynlib_handle_ptr handle) } /* Exported functions. */ - Lisp_Object func_list = retrive_litteral_obj (handle, TEXT_EXPORTED_FUNC_RELOC_SYM); + Lisp_Object func_list = retrive_literal_obj (handle, TEXT_EXPORTED_FUNC_RELOC_SYM); while (func_list) { commit 211db146a2f475047b38b010ea55c27c08701114 Author: Andrea Corallo Date: Sun Sep 1 17:16:13 2019 +0200 add record_unwind_current_buffer as imported diff --git a/src/comp.c b/src/comp.c index f428a440b0..58f86322ac 100644 --- a/src/comp.c +++ b/src/comp.c @@ -31,6 +31,7 @@ along with GNU Emacs. If not, see . */ #include "puresize.h" #include "window.h" #include "dynlib.h" +#include "buffer.h" #define DEFAULT_SPEED 2 /* See comp-speed var. */ @@ -172,19 +173,16 @@ static comp_t comp; FILE *logfile = NULL; +/* + Helper functions called by the runtime. +*/ Lisp_Object helper_save_window_excursion (Lisp_Object v1); - void helper_unwind_protect (Lisp_Object handler); - Lisp_Object helper_temp_output_buffer_setup (Lisp_Object x); - Lisp_Object helper_unbind_n (Lisp_Object n); - bool helper_PSEUDOVECTOR_TYPEP_XUNTAG (const union vectorlike_header *a, enum pvec_type code); - void helper_emit_save_restriction (void); - void helper_set_data_relocs (Lisp_Object *d_relocs_vec, char const *relocs); @@ -1596,6 +1594,8 @@ declare_runtime_imported (void) args[0] = comp.lisp_obj_type; ADD_IMPORTED ("helper_unbind_n", comp.lisp_obj_type, 1, args); + ADD_IMPORTED ("record_unwind_current_buffer", comp.void_type, 0, NULL); + #undef ADD_IMPORTED return field_list; @@ -3069,6 +3069,9 @@ load_comp_unit (dynlib_handle_ptr handle) } else if (!strcmp (f_str, "helper_unbind_n")) { f_relocs[i] = (void *) helper_unbind_n; + } else if (!strcmp (f_str, "record_unwind_current_buffer")) + { + f_relocs[i] = (void *) record_unwind_current_buffer; } else { error ("Unexpected function relocation %s", f_str); commit 6df64d170a93970fd57932980fceed6bf1853ccb Author: Andrea Corallo Date: Sun Sep 1 17:02:35 2019 +0200 fix relocation emission into comp.el diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index e9f9cd2db4..65944e5dd8 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -177,7 +177,8 @@ LIMPLE basic block.") "Keep track of OBJ into the ctxt relocations. The corresponding index is returned." (let ((data-relocs-idx (comp-ctxt-data-relocs-idx comp-ctxt))) - (unless (gethash obj data-relocs-idx) + (if-let ((idx (gethash obj data-relocs-idx))) + idx (push obj (comp-ctxt-data-relocs-l comp-ctxt)) (puthash obj (hash-table-count data-relocs-idx) data-relocs-idx)))) @@ -185,7 +186,8 @@ The corresponding index is returned." "Keep track of SUBR-NAME into the ctxt relocations. The corresponding index is returned." (let ((func-relocs-idx (comp-ctxt-func-relocs-idx comp-ctxt))) - (unless (gethash subr-name func-relocs-idx) + (if-let ((idx (gethash subr-name func-relocs-idx))) + idx (push subr-name (comp-ctxt-func-relocs-l comp-ctxt)) (puthash subr-name (hash-table-count func-relocs-idx) func-relocs-idx)))) @@ -392,6 +394,7 @@ If DST-N is specified use it otherwise assume it to be the current slot." (defun comp-emit-set-const (val) "Set constant VAL to current slot." (let ((rel-idx (comp-add-const-to-relocs val))) + (cl-assert (numberp rel-idx)) (setf (comp-slot) (make-comp-mvar :slot (comp-sp) :constant val)) (comp-emit `(setimm ,(comp-slot) ,rel-idx ,val)))) @@ -848,7 +851,9 @@ the annotation emission." (prin1-to-string (cl-loop with h = (comp-ctxt-funcs-h comp-ctxt) for f being each hash-value of h for args = (comp-func-args f) - for doc = (aref (comp-func-byte-func f) 4) + for doc = (when (> (length (comp-func-byte-func f)) + 4) + (aref (comp-func-byte-func f) 4)) collect (vector (comp-func-symbol-name f) (comp-func-c-func-name f) (cons (comp-args-base-min args) commit 94c542da1ac13fc6052d02fc7b960176c09bbaa8 Author: Andrea Corallo Date: Sun Sep 1 16:49:42 2019 +0200 add more runtime helpers diff --git a/src/comp.c b/src/comp.c index 6837100651..f428a440b0 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1591,6 +1591,11 @@ declare_runtime_imported (void) args[0] = gcc_jit_type_get_pointer (gcc_jit_struct_as_type (comp.jmp_buf_s)); ADD_IMPORTED (SETJMP_NAME, comp.int_type, 1, args); + ADD_IMPORTED ("record_unwind_protect_excursion", comp.void_type, 0, NULL); + + args[0] = comp.lisp_obj_type; + ADD_IMPORTED ("helper_unbind_n", comp.lisp_obj_type, 1, args); + #undef ADD_IMPORTED return field_list; @@ -3058,6 +3063,12 @@ load_comp_unit (dynlib_handle_ptr handle) } else if (!strcmp (f_str, SETJMP_NAME)) { f_relocs[i] = (void *) SETJMP; + } else if (!strcmp (f_str, "record_unwind_protect_excursion")) + { + f_relocs[i] = (void *) record_unwind_protect_excursion; + } else if (!strcmp (f_str, "helper_unbind_n")) + { + f_relocs[i] = (void *) helper_unbind_n; } else { error ("Unexpected function relocation %s", f_str); commit 895bb4c9112c715a1bfa66d9af0d945f4719db55 Author: Andrea Corallo Date: Sun Sep 1 16:16:25 2019 +0200 fix func reloc order emission diff --git a/src/comp.c b/src/comp.c index 9dac0f9c8e..6837100651 100644 --- a/src/comp.c +++ b/src/comp.c @@ -274,7 +274,6 @@ register_emitter (Lisp_Object key, void *func) Fputhash (key, value, comp.emitter_dispatcher); } - INLINE static void emit_comment (const char *str) { @@ -1573,7 +1572,8 @@ declare_runtime_imported (void) Lisp_Object name = intern_c_string (f_name); \ Lisp_Object field = \ make_mint_ptr (declare_imported_func (name, ret_type, nargs, args)); \ - field_list = Fcons (field, field_list); \ + Lisp_Object el = Fcons (name, field); \ + field_list = Fcons (el, field_list); \ } while (0) gcc_jit_type *args[2]; ADD_IMPORTED ("wrong_type_argument", comp.void_type, 2, NULL); @@ -1632,11 +1632,14 @@ emit_ctxt_code (void) f_reloc_len += XFIXNUM (Flength (f_subr)); gcc_jit_field *fields[f_reloc_len]; - int i = 0; + Lisp_Object f_reloc_list = Qnil; + int n_frelocs = 0; FOR_EACH_TAIL (f_runtime) { - fields[i++] = xmint_pointer( XCAR (f_runtime)); + Lisp_Object el = XCAR (f_runtime); + fields[n_frelocs++] = xmint_pointer( XCDR (el)); + f_reloc_list = Fcons (XCAR (el), f_reloc_list); } FOR_EACH_TAIL (f_subr) @@ -1650,15 +1653,26 @@ emit_ctxt_code (void) gcc_jit_field *field = declare_imported_func (subr_sym, comp.lisp_obj_type, FIXNUMP (maxarg) ? XFIXNUM (maxarg) : MANY, NULL); - fields [i++] = field; + fields [n_frelocs++] = field; + f_reloc_list = Fcons (subr_sym, f_reloc_list); } } + Lisp_Object f_reloc_vec = make_vector (n_frelocs, Qnil); + f_reloc_list = Freverse (f_reloc_list); + ptrdiff_t i = 0; + FOR_EACH_TAIL (f_reloc_list) + { + ASET (f_reloc_vec, i++, XCAR (f_reloc_list)); + } + emit_litteral_string_func (TEXT_IMPORTED_FUNC_RELOC_SYM, + (SSDATA (Fprin1_to_string (f_reloc_vec, Qnil)))); + gcc_jit_struct *f_reloc_struct = gcc_jit_context_new_struct_type (comp.ctxt, NULL, "function_reloc_struct", - i, fields); + n_frelocs, fields); comp.func_relocs = gcc_jit_context_new_global ( comp.ctxt, @@ -2835,17 +2849,6 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, for (ptrdiff_t i = 0; i < func_h->count; i++) compile_function (HASH_VALUE (func_h, i)); - /* FIXME wrap me */ - struct Lisp_Hash_Table *fh = XHASH_TABLE (comp.func_hash); - Lisp_Object f_reloc = make_vector (fh->count, Qnil); - for (ptrdiff_t i = 0; i < fh->count; i++) - { - Lisp_Object subr_sym = HASH_KEY (fh, i); - ASET (f_reloc, i, subr_sym); - } - emit_litteral_string_func ("text_imported_funcs", - (SSDATA (Fprin1_to_string (f_reloc, Qnil)))); - /* FIXME use format_string here */ if (COMP_DEBUG) { commit b9b5cf4196e7a5368c5e36c0c5e0364b5d3e15b3 Author: Andrea Corallo Date: Sun Sep 1 15:35:31 2019 +0200 ignore inliners while relocating diff --git a/src/comp.c b/src/comp.c index ae53fce380..9dac0f9c8e 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1642,21 +1642,23 @@ emit_ctxt_code (void) FOR_EACH_TAIL (f_subr) { Lisp_Object subr_sym = XCAR (f_subr); - Lisp_Object subr = Fsymbol_function (subr_sym); - Lisp_Object maxarg = XCDR (Fsubr_arity (subr)); - gcc_jit_field *field = - declare_imported_func (subr_sym, comp.lisp_obj_type, - FIXNUMP (maxarg) ? XFIXNUM (maxarg) : MANY, NULL); - fields [i++] = field; + /* Ignore inliners. This are not real functions to be imported. */ + if (NILP (Fgethash (subr_sym, comp.emitter_dispatcher, Qnil))) + { + Lisp_Object subr = Fsymbol_function (subr_sym); + Lisp_Object maxarg = XCDR (Fsubr_arity (subr)); + gcc_jit_field *field = + declare_imported_func (subr_sym, comp.lisp_obj_type, + FIXNUMP (maxarg) ? XFIXNUM (maxarg) : MANY, NULL); + fields [i++] = field; + } } - eassert (f_reloc_len == i); gcc_jit_struct *f_reloc_struct = gcc_jit_context_new_struct_type (comp.ctxt, NULL, "function_reloc_struct", - f_reloc_len, - fields); + i, fields); comp.func_relocs = gcc_jit_context_new_global ( comp.ctxt, @@ -3139,7 +3141,7 @@ syms_of_comp (void) DEFSYM (Qpop_handler, "pop-handler"); DEFSYM (Qcondition_case, "condition-case"); /* call operands. */ - DEFSYM (Qcatcher, "catcher"); + DEFSYM (Qcatcher, "catcher"); /* FIXME use these allover. */ DEFSYM (Qentry, "entry"); DEFSYM (Qset_internal, "set_internal"); DEFSYM (Qrecord_unwind_current_buffer, "record_unwind_current_buffer"); commit 999e625bc94d08eadf92d42d5bb0fd6f6d35c268 Author: Andrea Corallo Date: Sun Sep 1 14:46:29 2019 +0200 adding runtime relocs diff --git a/src/comp.c b/src/comp.c index 77b160c096..ae53fce380 100644 --- a/src/comp.c +++ b/src/comp.c @@ -52,7 +52,8 @@ along with GNU Emacs. If not, see . */ #define TEXT_EXPORTED_FUNC_RELOC_SYM "text_exported_funcs" #define TEXT_IMPORTED_FUNC_RELOC_SYM "text_imported_funcs" -#define STR(s) #s +#define STR_VALUE(s) #s +#define STR(s) STR_VALUE (s) #define FIRST(x) \ XCAR(x) @@ -70,6 +71,13 @@ along with GNU Emacs. If not, see . */ gcc_jit_block *(name) = \ gcc_jit_function_new_block ((func), STR(name)) +#ifdef HAVE__SETJMP +#define SETJMP _setjmp +#else +#define SETJMP setjmp +#endif +#define SETJMP_NAME STR (SETJMP) + /* C side of the compiler context. */ typedef struct { @@ -1157,11 +1165,7 @@ emit_limple_push_handler (gcc_jit_rvalue *handler, gcc_jit_rvalue *handler_type, NULL); gcc_jit_rvalue *res; -#ifdef HAVE__SETJMP - res = emit_call (intern_c_string ("_setjmp"), comp.int_type, 1, args); -#else - res = emit_call (intern_c_string ("setjmp"), comp.int_type, 1, args); -#endif + res = emit_call (intern_c_string (SETJMP_NAME), comp.int_type, 1, args); emit_cond_jump (res, handler_bb, guarded_bb); /* This emit the handler part. */ @@ -1561,20 +1565,32 @@ declare_runtime_imported (void) FUNCALL1 (comp-add-subr-to-relocs, intern_c_string ("1-")); FUNCALL1 (comp-add-subr-to-relocs, Qplus); FUNCALL1 (comp-add-subr-to-relocs, Qminus); + FUNCALL1 (comp-add-subr-to-relocs, Qlist); Lisp_Object field_list = Qnil; #define ADD_IMPORTED(f_name, ret_type, nargs, args) \ - { \ - Lisp_Object name = intern_c_string (f_name); \ - Lisp_Object field = \ - make_mint_ptr (declare_imported_func (name, ret_type, nargs, args)); \ - field_list = Fcons (field, field_list); \ - } while (0) - + { \ + Lisp_Object name = intern_c_string (f_name); \ + Lisp_Object field = \ + make_mint_ptr (declare_imported_func (name, ret_type, nargs, args)); \ + field_list = Fcons (field, field_list); \ + } while (0) + gcc_jit_type *args[2]; ADD_IMPORTED ("wrong_type_argument", comp.void_type, 2, NULL); - gcc_jit_type *args[] = {comp.lisp_obj_type, comp.int_type}; + + args[0] = comp.lisp_obj_type; + args[1] = comp.int_type; ADD_IMPORTED ("helper_PSEUDOVECTOR_TYPEP_XUNTAG", comp.bool_type, 2, args); + ADD_IMPORTED ("pure_write_error", comp.void_type, 1, NULL); + + args[0] = comp.lisp_obj_type; + args[1] = comp.int_type; + ADD_IMPORTED ("push_handler", comp.handler_ptr_type, 2, args); + + args[0] = gcc_jit_type_get_pointer (gcc_jit_struct_as_type (comp.jmp_buf_s)); + ADD_IMPORTED (SETJMP_NAME, comp.int_type, 1, args); + #undef ADD_IMPORTED return field_list; @@ -3031,6 +3047,12 @@ load_comp_unit (dynlib_handle_ptr handle) } else if (!strcmp (f_str, "pure_write_error")) { f_relocs[i] = (void *) pure_write_error; + } else if (!strcmp (f_str, "push_handler")) + { + f_relocs[i] = (void *) push_handler; + } else if (!strcmp (f_str, SETJMP_NAME)) + { + f_relocs[i] = (void *) SETJMP; } else { error ("Unexpected function relocation %s", f_str); commit bfc298ca31d11c09d49d792a88a9f72415bb4513 Author: Andrea Corallo Date: Sun Sep 1 14:27:11 2019 +0200 style fix in emit_limple_push_handler diff --git a/src/comp.c b/src/comp.c index bf1ff3be5d..77b160c096 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1132,7 +1132,6 @@ emit_limple_push_handler (gcc_jit_rvalue *handler, gcc_jit_rvalue *handler_type, /* Ex: (push-handler #s(comp-mvar 6 0 t (arith-error) nil) 1 bb_3 bb_2). */ static unsigned pushhandler_n; /* FIXME move at ctxt or func level. */ - gcc_jit_rvalue *args[2]; /* struct handler *c = push_handler (POP, type); */ gcc_jit_lvalue *c = @@ -1141,8 +1140,8 @@ emit_limple_push_handler (gcc_jit_rvalue *handler, gcc_jit_rvalue *handler_type, comp.handler_ptr_type, format_string ("c_%u", pushhandler_n)); - args[0] = handler; - args[1] = handler_type; + + gcc_jit_rvalue *args[] = { handler, handler_type }; gcc_jit_block_add_assignment ( comp.block, NULL, commit 76021e1e06c5c1af05b658310505da333bc0c214 Author: Andrea Corallo Date: Sun Sep 1 12:52:05 2019 +0200 always release contex even in case of failure diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 631003da1d..e9f9cd2db4 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -886,10 +886,11 @@ the annotation emission." comp-passes) ;; Once we have the final LIMPLE we jump into C. (comp--init-ctxt) - (comp-add-func-to-ctxt func) - (comp-compile-ctxt-to-file (symbol-name func-symbol-name)) - ;; (comp-compile-and-load-ctxt) - (comp--release-ctxt))) + (unwind-protect + (progn + (comp-add-func-to-ctxt func) + (comp-compile-ctxt-to-file (symbol-name func-symbol-name))) + (comp--release-ctxt)))) (error "Trying to native compile something not a function"))) (provide 'comp) commit 90425b6d4b314f8f4c26cbf61ec24fdffec4c0f7 Author: Andrea Corallo Date: Sun Sep 1 12:40:54 2019 +0200 better messaging when load native elisp diff --git a/src/lread.c b/src/lread.c index 1a5074cb70..b10743f980 100644 --- a/src/lread.c +++ b/src/lread.c @@ -1534,6 +1534,8 @@ Return t if the file exists and loads successfully. */) file, 1); else if (is_module) message_with_string ("Loading %s (module)...done", file, 1); + else if (is_native_elisp) + message_with_string ("Loading %s (native compiled elisp)...done", file, 1); else if (!compiled) message_with_string ("Loading %s (source)...done", file, 1); else if (newer) commit a102f471b3973d46d6954bc31c6170ddffd508da Author: Andrea Corallo Date: Sun Sep 1 12:29:13 2019 +0200 emit relocs for callref too diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 3bd4aa3131..631003da1d 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -363,7 +363,7 @@ SP-DELTA is the stack adjustment." "%s contains unevalled arg" subr-name) (if (eq maxarg 'many) ;; callref case. - `(comp-emit-set-call (list 'callref ',subr-name ,nargs (comp-sp))) + `(comp-emit-set-call (comp-callref ',subr-name ,nargs (comp-sp))) ;; Normal call. (cl-assert (and (>= maxarg nargs) (<= minarg nargs)) (nargs maxarg minarg) @@ -533,13 +533,13 @@ NARG is the number of Ffuncall arguments." )) (if optimize (if callref - (comp-emit-set-call `(callref ,callee-sym-name - ,narg ,(1+ (comp-sp)))) + (comp-emit-set-call (comp-callref callee-sym-name + narg (1+ (comp-sp)))) (comp-emit-set-call `(call ,callee-sym-name ,@(cl-loop for i from (1+ (comp-sp)) repeat narg collect (comp-slot-n i))))) - (comp-emit-set-call `(callref Ffuncall ,(1+ narg) ,(comp-sp)))))) + (comp-emit-set-call (comp-callref 'funcall (1+ narg) (comp-sp)))))) (defmacro comp-op-case (&rest cases) "Expand CASES into the corresponding pcase. commit c698ac791b3755c340ff945c137f6732cd4e20e4 Author: Andrea Corallo Date: Sun Sep 1 11:58:20 2019 +0200 add authorship diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index a14438e250..3bd4aa3131 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1,5 +1,7 @@ ;;; comp.el --- compilation of Lisp code into native code -*- lexical-binding: t -*- +;; Author: Andrea Corallo + ;; Copyright (C) 2019 Free Software Foundation, Inc. ;; Keywords: lisp diff --git a/src/comp.c b/src/comp.c index b108335560..bf1ff3be5d 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1,6 +1,8 @@ /* Compile byte code produced by bytecomp.el into native code. Copyright (C) 2019 Free Software Foundation, Inc. +Author: Andrea Corallo + This file is part of GNU Emacs. GNU Emacs is free software: you can redistribute it and/or modify commit a2b1795b96b5ac5981220b1056f6ea222bc193f5 Author: Andrea Corallo Date: Sun Sep 1 11:23:00 2019 +0200 clean-up unnecessary includes diff --git a/src/comp.c b/src/comp.c index 0f8c9648cd..b108335560 100644 --- a/src/comp.c +++ b/src/comp.c @@ -27,9 +27,6 @@ along with GNU Emacs. If not, see . */ #include "lisp.h" #include "puresize.h" -#include "buffer.h" -#include "bytecode.h" -#include "atimer.h" #include "window.h" #include "dynlib.h" commit a2257a531d0cd4c1d2bbfe374f490fa956be0330 Author: Andrea Corallo Date: Sun Sep 1 11:22:35 2019 +0200 add NATIVE_ELISP_SUFFIX def into congure.ac diff --git a/configure.ac b/configure.ac index d059b7d672..6213051a60 100644 --- a/configure.ac +++ b/configure.ac @@ -3678,6 +3678,8 @@ if test "${with_nativecomp}" != "no"; then if test "${HAVE_LIBGCCJIT}" = "yes"; then LIBGCCJIT_LIB=-lgccjit AC_DEFINE([HAVE_LIBGCCJIT], 1, [Define to 1 if you have the libgccjit library (-lgccjit).]) + AC_DEFINE_UNQUOTED(NATIVE_ELISP_SUFFIX, ".eln", + [System extension for native compiled elisp]) fi fi AC_SUBST([LIBGCCJIT_LIB]) commit 3b696d1cdcc79505313b2f087fbf742e503a1998 Author: Andrea Corallo Date: Sun Sep 1 11:07:11 2019 +0200 Revert "Make block_atimers unblock_atimers extern" This reverts commit 4266794ceb30ba8c3465fb8568695f53b676247d. diff --git a/src/atimer.c b/src/atimer.c index 4b0cab1453..a7daf9dcf5 100644 --- a/src/atimer.c +++ b/src/atimer.c @@ -65,6 +65,22 @@ enum { timerfd = -1 }; # endif #endif +/* Block/unblock SIGALRM. */ + +static void +block_atimers (sigset_t *oldset) +{ + sigset_t blocked; + sigemptyset (&blocked); + sigaddset (&blocked, SIGALRM); + sigaddset (&blocked, SIGINT); + pthread_sigmask (SIG_BLOCK, &blocked, oldset); +} +static void +unblock_atimers (sigset_t const *oldset) +{ + pthread_sigmask (SIG_SETMASK, oldset, 0); +} /* Function prototypes. */ @@ -149,23 +165,6 @@ start_atimer (enum atimer_type type, struct timespec timestamp, return t; } -/* Block/unblock SIGALRM. */ - -void -block_atimers (sigset_t *oldset) -{ - sigset_t blocked; - sigemptyset (&blocked); - sigaddset (&blocked, SIGALRM); - sigaddset (&blocked, SIGINT); - pthread_sigmask (SIG_BLOCK, &blocked, oldset); -} - -void -unblock_atimers (sigset_t const *oldset) -{ - pthread_sigmask (SIG_SETMASK, oldset, 0); -} /* Cancel and free atimer TIMER. */ diff --git a/src/atimer.h b/src/atimer.h index 58209168af..660d77c939 100644 --- a/src/atimer.h +++ b/src/atimer.h @@ -71,8 +71,6 @@ struct atimer struct atimer *start_atimer (enum atimer_type, struct timespec, atimer_callback, void *); -void block_atimers (sigset_t *); -void unblock_atimers (sigset_t const *); void cancel_atimer (struct atimer *); void do_pending_atimers (void); void init_atimer (void); commit 4c03c46946d95a7e9079a087b5e0e835f5a5beac Author: Andrea Corallo Date: Sun Sep 1 11:06:27 2019 +0200 Revert "Move native C code into shared library" This reverts commit 613f4156880bc6c3d56ebe0297e59f805d2a69ab. diff --git a/lib/Makefile.in b/lib/Makefile.in index ed3123885d..06d8e56421 100644 --- a/lib/Makefile.in +++ b/lib/Makefile.in @@ -26,8 +26,6 @@ abs_top_srcdir = @abs_top_srcdir@ top_builddir = @top_builddir@ top_srcdir = @top_srcdir@ -CFLAGS = -fPIC @CFLAGS@ - all: .PHONY: all @@ -52,7 +50,7 @@ am__v_at_ = $(am__v_at_@AM_DEFAULT_V@) am__v_at_0 = @ am__v_at_1 = -ALL_CFLAGS= -fPIC \ +ALL_CFLAGS= \ $(C_SWITCH_SYSTEM) $(C_SWITCH_MACHINE) $(DEPFLAGS) \ $(GNULIB_WARN_CFLAGS) $(WERROR_CFLAGS) $(PROFILING_CFLAGS) $(CFLAGS) \ -I. -I../src -I$(srcdir) -I$(srcdir)/../src \ diff --git a/src/Makefile.in b/src/Makefile.in index 8e3712709e..5e0e36d8b4 100644 --- a/src/Makefile.in +++ b/src/Makefile.in @@ -33,7 +33,7 @@ top_srcdir = @top_srcdir@ abs_top_srcdir=@abs_top_srcdir@ VPATH = $(srcdir) CC = @CC@ -CFLAGS = @CFLAGS@ -fPIC +CFLAGS = @CFLAGS@ CPPFLAGS = @CPPFLAGS@ LDFLAGS = @LDFLAGS@ EXEEXT = @EXEEXT@ @@ -465,7 +465,7 @@ FIRSTFILE_OBJ=@FIRSTFILE_OBJ@ ALLOBJS = $(FIRSTFILE_OBJ) $(VMLIMIT_OBJ) $(obj) $(otherobj) # Must be first, before dep inclusion! -all: $(pdmp) $(OTHER_FILES) +all: emacs$(EXEEXT) $(pdmp) $(OTHER_FILES) .PHONY: all dmpstruct_headers=$(srcdir)/lisp.h $(srcdir)/buffer.h \ @@ -644,33 +644,25 @@ else MAKE_PDUMPER_FINGERPRINT = endif -## FIXME: dumper support totally missing here -libemacs.so: $(LIBXMENU) $(ALLOBJS) $(LIBEGNU_ARCHIVE) $(EMACSRES) \ - $(charsets) $(charscript) $(MAKE_PDUMPER_FINGERPRINT) main.o - $(CC) --shared -o $@ $(ALLOBJS) -Wl,-Bstatic $(LIBEGNU_ARCHIVE) -Wl,-Bdynamic $(LIBES) - -temacs$(EXEEXT): libemacs.so main.o - $(CC) -L. main.o -o $@ $(TEMACS_LDFLAGS) $(LDFLAGS) \ - $(ALLOBJS) $(LIBEGNU_ARCHIVE) $(W32_RES_LINK) $(LIBES) -lemacs -Wl,-rpath -Wl,$(shell pwd) - -# ## We have to create $(etc) here because init_cmdargs tests its -# ## existence when setting Vinstallation_directory (FIXME?). -# ## This goes on to affect various things, and the emacs binary fails -# ## to start if Vinstallation_directory has the wrong value. -# temacs$(EXEEXT): $(LIBXMENU) $(ALLOBJS) $(LIBEGNU_ARCHIVE) $(EMACSRES) \ -# $(charsets) $(charscript) $(MAKE_PDUMPER_FINGERPRINT) -# $(AM_V_CCLD)$(CC) -o $@.tmp \ -# $(ALL_CFLAGS) $(TEMACS_LDFLAGS) $(LDFLAGS) \ -# $(ALLOBJS) $(LIBEGNU_ARCHIVE) $(W32_RES_LINK) $(LIBES) -# ifeq ($(HAVE_PDUMPER),yes) -# $(AM_V_at)$(MAKE_PDUMPER_FINGERPRINT) $@.tmp -# endif -# $(AM_V_at)mv $@.tmp $@ -# $(MKDIR_P) $(etc) -# ifeq ($(DUMPING),unexec) -# ifneq ($(PAXCTL_notdumped),) -# $(PAXCTL_notdumped) $@ -# endif +## We have to create $(etc) here because init_cmdargs tests its +## existence when setting Vinstallation_directory (FIXME?). +## This goes on to affect various things, and the emacs binary fails +## to start if Vinstallation_directory has the wrong value. +temacs$(EXEEXT): $(LIBXMENU) $(ALLOBJS) $(LIBEGNU_ARCHIVE) $(EMACSRES) \ + $(charsets) $(charscript) $(MAKE_PDUMPER_FINGERPRINT) + $(AM_V_CCLD)$(CC) -o $@.tmp \ + $(ALL_CFLAGS) $(TEMACS_LDFLAGS) $(LDFLAGS) \ + $(ALLOBJS) $(LIBEGNU_ARCHIVE) $(W32_RES_LINK) $(LIBES) +ifeq ($(HAVE_PDUMPER),yes) + $(AM_V_at)$(MAKE_PDUMPER_FINGERPRINT) $@.tmp +endif + $(AM_V_at)mv $@.tmp $@ + $(MKDIR_P) $(etc) +ifeq ($(DUMPING),unexec) + ifneq ($(PAXCTL_notdumped),) + $(PAXCTL_notdumped) $@ + endif +endif ## The following oldxmenu-related rules are only (possibly) used if ## HAVE_X11 && !USE_GTK, but there is no harm in always defining them. diff --git a/src/emacs.c b/src/emacs.c index 1491ba5a47..c59a70988b 100644 --- a/src/emacs.c +++ b/src/emacs.c @@ -924,7 +924,7 @@ load_pdump (int argc, char **argv) #endif /* HAVE_PDUMPER */ int -main1 (int argc, char **argv) +main (int argc, char **argv) { /* Variable near the bottom of the stack, and aligned appropriately for pointers. */ diff --git a/src/main.c b/src/main.c deleted file mode 100644 index 41e3553428..0000000000 --- a/src/main.c +++ /dev/null @@ -1,26 +0,0 @@ -/* Trampoline for GNU Emacs. - Copyright (C) 2019 Free Software - Foundation, Inc. - -This file is part of GNU Emacs. - -GNU Emacs is free software: you can redistribute it and/or modify -it under the terms of the GNU General Public License as published by -the Free Software Foundation, either version 3 of the License, or (at -your option) any later version. - -GNU Emacs is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -GNU General Public License for more details. - -You should have received a copy of the GNU General Public License -along with GNU Emacs. If not, see . */ - -extern int main1 (int argc, char **argv); - -int -main (int argc, char **argv) -{ - return main1(argc, argv); -} commit e3163f1d4cec335b5941c9bea267fe161c5ab83d Author: Andrea Corallo Date: Sun Sep 1 11:06:12 2019 +0200 Revert "Create bytecode.h" This reverts commit c91954e5bb6365b72ad5654e932bc374a66fb4af. diff --git a/src/bytecode.c b/src/bytecode.c index e11704fd8b..9e75c9012e 100644 --- a/src/bytecode.c +++ b/src/bytecode.c @@ -27,7 +27,6 @@ along with GNU Emacs. If not, see . */ #include "ptr-bounds.h" #include "syntax.h" #include "window.h" -#include "bytecode.h" /* Work around GCC bug 54561. */ #if GNUC_PREREQ (4, 3, 0) @@ -78,6 +77,212 @@ along with GNU Emacs. If not, see . */ #endif /* BYTE_CODE_METER */ +/* Byte codes: */ + +#define BYTE_CODES \ +DEFINE (Bstack_ref, 0) /* Actually, Bstack_ref+0 is not implemented: use dup. */ \ +DEFINE (Bstack_ref1, 1) \ +DEFINE (Bstack_ref2, 2) \ +DEFINE (Bstack_ref3, 3) \ +DEFINE (Bstack_ref4, 4) \ +DEFINE (Bstack_ref5, 5) \ +DEFINE (Bstack_ref6, 6) \ +DEFINE (Bstack_ref7, 7) \ +DEFINE (Bvarref, 010) \ +DEFINE (Bvarref1, 011) \ +DEFINE (Bvarref2, 012) \ +DEFINE (Bvarref3, 013) \ +DEFINE (Bvarref4, 014) \ +DEFINE (Bvarref5, 015) \ +DEFINE (Bvarref6, 016) \ +DEFINE (Bvarref7, 017) \ +DEFINE (Bvarset, 020) \ +DEFINE (Bvarset1, 021) \ +DEFINE (Bvarset2, 022) \ +DEFINE (Bvarset3, 023) \ +DEFINE (Bvarset4, 024) \ +DEFINE (Bvarset5, 025) \ +DEFINE (Bvarset6, 026) \ +DEFINE (Bvarset7, 027) \ +DEFINE (Bvarbind, 030) \ +DEFINE (Bvarbind1, 031) \ +DEFINE (Bvarbind2, 032) \ +DEFINE (Bvarbind3, 033) \ +DEFINE (Bvarbind4, 034) \ +DEFINE (Bvarbind5, 035) \ +DEFINE (Bvarbind6, 036) \ +DEFINE (Bvarbind7, 037) \ +DEFINE (Bcall, 040) \ +DEFINE (Bcall1, 041) \ +DEFINE (Bcall2, 042) \ +DEFINE (Bcall3, 043) \ +DEFINE (Bcall4, 044) \ +DEFINE (Bcall5, 045) \ +DEFINE (Bcall6, 046) \ +DEFINE (Bcall7, 047) \ +DEFINE (Bunbind, 050) \ +DEFINE (Bunbind1, 051) \ +DEFINE (Bunbind2, 052) \ +DEFINE (Bunbind3, 053) \ +DEFINE (Bunbind4, 054) \ +DEFINE (Bunbind5, 055) \ +DEFINE (Bunbind6, 056) \ +DEFINE (Bunbind7, 057) \ + \ +DEFINE (Bpophandler, 060) \ +DEFINE (Bpushconditioncase, 061) \ +DEFINE (Bpushcatch, 062) \ + \ +DEFINE (Bnth, 070) \ +DEFINE (Bsymbolp, 071) \ +DEFINE (Bconsp, 072) \ +DEFINE (Bstringp, 073) \ +DEFINE (Blistp, 074) \ +DEFINE (Beq, 075) \ +DEFINE (Bmemq, 076) \ +DEFINE (Bnot, 077) \ +DEFINE (Bcar, 0100) \ +DEFINE (Bcdr, 0101) \ +DEFINE (Bcons, 0102) \ +DEFINE (Blist1, 0103) \ +DEFINE (Blist2, 0104) \ +DEFINE (Blist3, 0105) \ +DEFINE (Blist4, 0106) \ +DEFINE (Blength, 0107) \ +DEFINE (Baref, 0110) \ +DEFINE (Baset, 0111) \ +DEFINE (Bsymbol_value, 0112) \ +DEFINE (Bsymbol_function, 0113) \ +DEFINE (Bset, 0114) \ +DEFINE (Bfset, 0115) \ +DEFINE (Bget, 0116) \ +DEFINE (Bsubstring, 0117) \ +DEFINE (Bconcat2, 0120) \ +DEFINE (Bconcat3, 0121) \ +DEFINE (Bconcat4, 0122) \ +DEFINE (Bsub1, 0123) \ +DEFINE (Badd1, 0124) \ +DEFINE (Beqlsign, 0125) \ +DEFINE (Bgtr, 0126) \ +DEFINE (Blss, 0127) \ +DEFINE (Bleq, 0130) \ +DEFINE (Bgeq, 0131) \ +DEFINE (Bdiff, 0132) \ +DEFINE (Bnegate, 0133) \ +DEFINE (Bplus, 0134) \ +DEFINE (Bmax, 0135) \ +DEFINE (Bmin, 0136) \ +DEFINE (Bmult, 0137) \ + \ +DEFINE (Bpoint, 0140) \ +/* Was Bmark in v17. */ \ +DEFINE (Bsave_current_buffer, 0141) /* Obsolete. */ \ +DEFINE (Bgoto_char, 0142) \ +DEFINE (Binsert, 0143) \ +DEFINE (Bpoint_max, 0144) \ +DEFINE (Bpoint_min, 0145) \ +DEFINE (Bchar_after, 0146) \ +DEFINE (Bfollowing_char, 0147) \ +DEFINE (Bpreceding_char, 0150) \ +DEFINE (Bcurrent_column, 0151) \ +DEFINE (Bindent_to, 0152) \ +DEFINE (Beolp, 0154) \ +DEFINE (Beobp, 0155) \ +DEFINE (Bbolp, 0156) \ +DEFINE (Bbobp, 0157) \ +DEFINE (Bcurrent_buffer, 0160) \ +DEFINE (Bset_buffer, 0161) \ +DEFINE (Bsave_current_buffer_1, 0162) /* Replacing Bsave_current_buffer. */ \ +DEFINE (Binteractive_p, 0164) /* Obsolete since Emacs-24.1. */ \ + \ +DEFINE (Bforward_char, 0165) \ +DEFINE (Bforward_word, 0166) \ +DEFINE (Bskip_chars_forward, 0167) \ +DEFINE (Bskip_chars_backward, 0170) \ +DEFINE (Bforward_line, 0171) \ +DEFINE (Bchar_syntax, 0172) \ +DEFINE (Bbuffer_substring, 0173) \ +DEFINE (Bdelete_region, 0174) \ +DEFINE (Bnarrow_to_region, 0175) \ +DEFINE (Bwiden, 0176) \ +DEFINE (Bend_of_line, 0177) \ + \ +DEFINE (Bconstant2, 0201) \ +DEFINE (Bgoto, 0202) \ +DEFINE (Bgotoifnil, 0203) \ +DEFINE (Bgotoifnonnil, 0204) \ +DEFINE (Bgotoifnilelsepop, 0205) \ +DEFINE (Bgotoifnonnilelsepop, 0206) \ +DEFINE (Breturn, 0207) \ +DEFINE (Bdiscard, 0210) \ +DEFINE (Bdup, 0211) \ + \ +DEFINE (Bsave_excursion, 0212) \ +DEFINE (Bsave_window_excursion, 0213) /* Obsolete since Emacs-24.1. */ \ +DEFINE (Bsave_restriction, 0214) \ +DEFINE (Bcatch, 0215) \ + \ +DEFINE (Bunwind_protect, 0216) \ +DEFINE (Bcondition_case, 0217) \ +DEFINE (Btemp_output_buffer_setup, 0220) /* Obsolete since Emacs-24.1. */ \ +DEFINE (Btemp_output_buffer_show, 0221) /* Obsolete since Emacs-24.1. */ \ + \ +DEFINE (Bunbind_all, 0222) /* Obsolete. Never used. */ \ + \ +DEFINE (Bset_marker, 0223) \ +DEFINE (Bmatch_beginning, 0224) \ +DEFINE (Bmatch_end, 0225) \ +DEFINE (Bupcase, 0226) \ +DEFINE (Bdowncase, 0227) \ + \ +DEFINE (Bstringeqlsign, 0230) \ +DEFINE (Bstringlss, 0231) \ +DEFINE (Bequal, 0232) \ +DEFINE (Bnthcdr, 0233) \ +DEFINE (Belt, 0234) \ +DEFINE (Bmember, 0235) \ +DEFINE (Bassq, 0236) \ +DEFINE (Bnreverse, 0237) \ +DEFINE (Bsetcar, 0240) \ +DEFINE (Bsetcdr, 0241) \ +DEFINE (Bcar_safe, 0242) \ +DEFINE (Bcdr_safe, 0243) \ +DEFINE (Bnconc, 0244) \ +DEFINE (Bquo, 0245) \ +DEFINE (Brem, 0246) \ +DEFINE (Bnumberp, 0247) \ +DEFINE (Bintegerp, 0250) \ + \ +DEFINE (BRgoto, 0252) \ +DEFINE (BRgotoifnil, 0253) \ +DEFINE (BRgotoifnonnil, 0254) \ +DEFINE (BRgotoifnilelsepop, 0255) \ +DEFINE (BRgotoifnonnilelsepop, 0256) \ + \ +DEFINE (BlistN, 0257) \ +DEFINE (BconcatN, 0260) \ +DEFINE (BinsertN, 0261) \ + \ +/* Bstack_ref is code 0. */ \ +DEFINE (Bstack_set, 0262) \ +DEFINE (Bstack_set2, 0263) \ +DEFINE (BdiscardN, 0266) \ + \ +DEFINE (Bswitch, 0267) \ + \ +DEFINE (Bconstant, 0300) + +enum byte_code_op +{ +#define DEFINE(name, value) name = value, + BYTE_CODES +#undef DEFINE + +#if BYTE_CODE_SAFE + Bscan_buffer = 0153, /* No longer generated as of v18. */ + Bset_mark = 0163, /* this loser is no longer generated as of v18 */ +#endif +}; /* Fetch the next byte from the bytecode stream. */ diff --git a/src/bytecode.h b/src/bytecode.h deleted file mode 100644 index 07452eb185..0000000000 --- a/src/bytecode.h +++ /dev/null @@ -1,230 +0,0 @@ -/* Byte code definitions - Copyright (C) 1985-1988, 1993, 2000-2018 Free Software Foundation, - Inc. - -This file is part of GNU Emacs. - -GNU Emacs is free software: you can redistribute it and/or modify -it under the terms of the GNU General Public License as published by -the Free Software Foundation, either version 3 of the License, or (at -your option) any later version. - -GNU Emacs is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -GNU General Public License for more details. - -You should have received a copy of the GNU General Public License -along with GNU Emacs. If not, see . */ - -#ifndef EMACS_BYTECODE_H -#define EMACS_BYTECODE_H - -/* Byte codes: */ - -#define BYTE_CODES \ -DEFINE (Bstack_ref, 0) /* Actually, Bstack_ref+0 is not implemented: use dup. */ \ -DEFINE (Bstack_ref1, 1) \ -DEFINE (Bstack_ref2, 2) \ -DEFINE (Bstack_ref3, 3) \ -DEFINE (Bstack_ref4, 4) \ -DEFINE (Bstack_ref5, 5) \ -DEFINE (Bstack_ref6, 6) \ -DEFINE (Bstack_ref7, 7) \ -DEFINE (Bvarref, 010) \ -DEFINE (Bvarref1, 011) \ -DEFINE (Bvarref2, 012) \ -DEFINE (Bvarref3, 013) \ -DEFINE (Bvarref4, 014) \ -DEFINE (Bvarref5, 015) \ -DEFINE (Bvarref6, 016) \ -DEFINE (Bvarref7, 017) \ -DEFINE (Bvarset, 020) \ -DEFINE (Bvarset1, 021) \ -DEFINE (Bvarset2, 022) \ -DEFINE (Bvarset3, 023) \ -DEFINE (Bvarset4, 024) \ -DEFINE (Bvarset5, 025) \ -DEFINE (Bvarset6, 026) \ -DEFINE (Bvarset7, 027) \ -DEFINE (Bvarbind, 030) \ -DEFINE (Bvarbind1, 031) \ -DEFINE (Bvarbind2, 032) \ -DEFINE (Bvarbind3, 033) \ -DEFINE (Bvarbind4, 034) \ -DEFINE (Bvarbind5, 035) \ -DEFINE (Bvarbind6, 036) \ -DEFINE (Bvarbind7, 037) \ -DEFINE (Bcall, 040) \ -DEFINE (Bcall1, 041) \ -DEFINE (Bcall2, 042) \ -DEFINE (Bcall3, 043) \ -DEFINE (Bcall4, 044) \ -DEFINE (Bcall5, 045) \ -DEFINE (Bcall6, 046) \ -DEFINE (Bcall7, 047) \ -DEFINE (Bunbind, 050) \ -DEFINE (Bunbind1, 051) \ -DEFINE (Bunbind2, 052) \ -DEFINE (Bunbind3, 053) \ -DEFINE (Bunbind4, 054) \ -DEFINE (Bunbind5, 055) \ -DEFINE (Bunbind6, 056) \ -DEFINE (Bunbind7, 057) \ - \ -DEFINE (Bpophandler, 060) \ -DEFINE (Bpushconditioncase, 061) \ -DEFINE (Bpushcatch, 062) \ - \ -DEFINE (Bnth, 070) \ -DEFINE (Bsymbolp, 071) \ -DEFINE (Bconsp, 072) \ -DEFINE (Bstringp, 073) \ -DEFINE (Blistp, 074) \ -DEFINE (Beq, 075) \ -DEFINE (Bmemq, 076) \ -DEFINE (Bnot, 077) \ -DEFINE (Bcar, 0100) \ -DEFINE (Bcdr, 0101) \ -DEFINE (Bcons, 0102) \ -DEFINE (Blist1, 0103) \ -DEFINE (Blist2, 0104) \ -DEFINE (Blist3, 0105) \ -DEFINE (Blist4, 0106) \ -DEFINE (Blength, 0107) \ -DEFINE (Baref, 0110) \ -DEFINE (Baset, 0111) \ -DEFINE (Bsymbol_value, 0112) \ -DEFINE (Bsymbol_function, 0113) \ -DEFINE (Bset, 0114) \ -DEFINE (Bfset, 0115) \ -DEFINE (Bget, 0116) \ -DEFINE (Bsubstring, 0117) \ -DEFINE (Bconcat2, 0120) \ -DEFINE (Bconcat3, 0121) \ -DEFINE (Bconcat4, 0122) \ -DEFINE (Bsub1, 0123) \ -DEFINE (Badd1, 0124) \ -DEFINE (Beqlsign, 0125) \ -DEFINE (Bgtr, 0126) \ -DEFINE (Blss, 0127) \ -DEFINE (Bleq, 0130) \ -DEFINE (Bgeq, 0131) \ -DEFINE (Bdiff, 0132) \ -DEFINE (Bnegate, 0133) \ -DEFINE (Bplus, 0134) \ -DEFINE (Bmax, 0135) \ -DEFINE (Bmin, 0136) \ -DEFINE (Bmult, 0137) \ - \ -DEFINE (Bpoint, 0140) \ -/* Was Bmark in v17. */ \ -DEFINE (Bsave_current_buffer, 0141) /* Obsolete. */ \ -DEFINE (Bgoto_char, 0142) \ -DEFINE (Binsert, 0143) \ -DEFINE (Bpoint_max, 0144) \ -DEFINE (Bpoint_min, 0145) \ -DEFINE (Bchar_after, 0146) \ -DEFINE (Bfollowing_char, 0147) \ -DEFINE (Bpreceding_char, 0150) \ -DEFINE (Bcurrent_column, 0151) \ -DEFINE (Bindent_to, 0152) \ -DEFINE (Beolp, 0154) \ -DEFINE (Beobp, 0155) \ -DEFINE (Bbolp, 0156) \ -DEFINE (Bbobp, 0157) \ -DEFINE (Bcurrent_buffer, 0160) \ -DEFINE (Bset_buffer, 0161) \ -DEFINE (Bsave_current_buffer_1, 0162) /* Replacing Bsave_current_buffer. */ \ -DEFINE (Binteractive_p, 0164) /* Obsolete since Emacs-24.1. */ \ - \ -DEFINE (Bforward_char, 0165) \ -DEFINE (Bforward_word, 0166) \ -DEFINE (Bskip_chars_forward, 0167) \ -DEFINE (Bskip_chars_backward, 0170) \ -DEFINE (Bforward_line, 0171) \ -DEFINE (Bchar_syntax, 0172) \ -DEFINE (Bbuffer_substring, 0173) \ -DEFINE (Bdelete_region, 0174) \ -DEFINE (Bnarrow_to_region, 0175) \ -DEFINE (Bwiden, 0176) \ -DEFINE (Bend_of_line, 0177) \ - \ -DEFINE (Bconstant2, 0201) \ -DEFINE (Bgoto, 0202) \ -DEFINE (Bgotoifnil, 0203) \ -DEFINE (Bgotoifnonnil, 0204) \ -DEFINE (Bgotoifnilelsepop, 0205) \ -DEFINE (Bgotoifnonnilelsepop, 0206) \ -DEFINE (Breturn, 0207) \ -DEFINE (Bdiscard, 0210) \ -DEFINE (Bdup, 0211) \ - \ -DEFINE (Bsave_excursion, 0212) \ -DEFINE (Bsave_window_excursion, 0213) /* Obsolete since Emacs-24.1. */ \ -DEFINE (Bsave_restriction, 0214) \ -DEFINE (Bcatch, 0215) \ - \ -DEFINE (Bunwind_protect, 0216) \ -DEFINE (Bcondition_case, 0217) \ -DEFINE (Btemp_output_buffer_setup, 0220) /* Obsolete since Emacs-24.1. */ \ -DEFINE (Btemp_output_buffer_show, 0221) /* Obsolete since Emacs-24.1. */ \ - \ -DEFINE (Bunbind_all, 0222) /* Obsolete. Never used. */ \ - \ -DEFINE (Bset_marker, 0223) \ -DEFINE (Bmatch_beginning, 0224) \ -DEFINE (Bmatch_end, 0225) \ -DEFINE (Bupcase, 0226) \ -DEFINE (Bdowncase, 0227) \ - \ -DEFINE (Bstringeqlsign, 0230) \ -DEFINE (Bstringlss, 0231) \ -DEFINE (Bequal, 0232) \ -DEFINE (Bnthcdr, 0233) \ -DEFINE (Belt, 0234) \ -DEFINE (Bmember, 0235) \ -DEFINE (Bassq, 0236) \ -DEFINE (Bnreverse, 0237) \ -DEFINE (Bsetcar, 0240) \ -DEFINE (Bsetcdr, 0241) \ -DEFINE (Bcar_safe, 0242) \ -DEFINE (Bcdr_safe, 0243) \ -DEFINE (Bnconc, 0244) \ -DEFINE (Bquo, 0245) \ -DEFINE (Brem, 0246) \ -DEFINE (Bnumberp, 0247) \ -DEFINE (Bintegerp, 0250) \ - \ -DEFINE (BRgoto, 0252) \ -DEFINE (BRgotoifnil, 0253) \ -DEFINE (BRgotoifnonnil, 0254) \ -DEFINE (BRgotoifnilelsepop, 0255) \ -DEFINE (BRgotoifnonnilelsepop, 0256) \ - \ -DEFINE (BlistN, 0257) \ -DEFINE (BconcatN, 0260) \ -DEFINE (BinsertN, 0261) \ - \ -/* Bstack_ref is code 0. */ \ -DEFINE (Bstack_set, 0262) \ -DEFINE (Bstack_set2, 0263) \ -DEFINE (BdiscardN, 0266) \ - \ -DEFINE (Bswitch, 0267) \ - \ -DEFINE (Bconstant, 0300) - -enum byte_code_op -{ -#define DEFINE(name, value) name = value, - BYTE_CODES -#undef DEFINE - -#if BYTE_CODE_SAFE - Bscan_buffer = 0153, /* No longer generated as of v18. */ - Bset_mark = 0163, /* this loser is no longer generated as of v18 */ -#endif -}; - -#endif /* EMACS_BYTECODE_H */ diff --git a/src/lisp.h b/src/lisp.h index 6f0177436d..93a3ddea0c 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -2096,8 +2096,6 @@ union Aligned_Lisp_Subr }; verify (GCALIGNED (union Aligned_Lisp_Subr)); -#define SUBR_MAX_ARGS 9 - INLINE bool SUBRP (Lisp_Object a) { commit dc52036074c46d1772557436cda2866b346b4d16 Author: Andrea Corallo Date: Sun Sep 1 10:35:10 2019 +0200 improve reloc mechanism diff --git a/src/comp.c b/src/comp.c index d7e8284545..0f8c9648cd 100644 --- a/src/comp.c +++ b/src/comp.c @@ -46,6 +46,13 @@ along with GNU Emacs. If not, see . */ #define CONST_PROP_MAX 0 +/* C symbols emited for the load relocation mechanism. */ +#define DATA_RELOC_SYM "d_reloc" +#define IMPORTED_FUNC_RELOC_SYM "f_reloc" +#define TEXT_DATA_RELOC_SYM "text_data_reloc" +#define TEXT_EXPORTED_FUNC_RELOC_SYM "text_exported_funcs" +#define TEXT_IMPORTED_FUNC_RELOC_SYM "text_imported_funcs" + #define STR(s) #s #define FIRST(x) \ @@ -147,7 +154,7 @@ typedef struct { gcc_jit_function *check_type; gcc_jit_function *check_impure; Lisp_Object func_blocks; /* blk_name -> gcc_block. */ - Lisp_Object func_hash; /* c_f_name -> (gcc_func . subr_name). */ + Lisp_Object func_hash; /* subr_name -> reloc_field. */ Lisp_Object emitter_dispatcher; gcc_jit_rvalue *data_relocs; /* Synthesized struct holding data relocs. */ gcc_jit_lvalue *func_relocs; /* Synthesized struct holding func relocs. */ @@ -287,7 +294,7 @@ declare_imported_func (Lisp_Object subr_sym, gcc_jit_type *ret_type, nargs = 2; types = alloca (nargs * sizeof (* types)); types[0] = comp.ptrdiff_type; - types[1] = comp.lisp_obj_type; + types[1] = comp.lisp_obj_ptr_type; } else if (!types) { @@ -316,9 +323,7 @@ declare_imported_func (Lisp_Object subr_sym, gcc_jit_type *ret_type, f_ptr_type, SSDATA (f_ptr_name)); - - Lisp_Object value = Fcons (make_mint_ptr (field), subr_sym); - Fputhash (subr_sym, value, comp.func_hash); + Fputhash (subr_sym, make_mint_ptr (field), comp.func_hash); return field; } @@ -369,7 +374,7 @@ emit_call (Lisp_Object subr_sym, gcc_jit_type *ret_type, unsigned nargs, gcc_jit_lvalue *f_ptr = gcc_jit_lvalue_access_field (comp.func_relocs, NULL, - (gcc_jit_field *) xmint_pointer (XCAR (value))); + (gcc_jit_field *) xmint_pointer (value)); if (!f_ptr) error ("Undeclared function relocation."); @@ -1556,8 +1561,8 @@ declare_runtime_imported (void) for functions imported by lisp code. */ FUNCALL1 (comp-add-subr-to-relocs, intern_c_string ("1+")); FUNCALL1 (comp-add-subr-to-relocs, intern_c_string ("1-")); - FUNCALL1 (comp-add-subr-to-relocs, intern_c_string ("+")); - FUNCALL1 (comp-add-subr-to-relocs, intern_c_string ("-")); + FUNCALL1 (comp-add-subr-to-relocs, Qplus); + FUNCALL1 (comp-add-subr-to-relocs, Qminus); Lisp_Object field_list = Qnil; #define ADD_IMPORTED(f_name, ret_type, nargs, args) \ @@ -1600,9 +1605,9 @@ emit_ctxt_code (void) NULL, comp.lisp_obj_type, d_reloc_len), - "data_relocs")); + DATA_RELOC_SYM)); - emit_litteral_string_func ("text_data_relocs", d_reloc); + emit_litteral_string_func (TEXT_DATA_RELOC_SYM, d_reloc); /* Imported functions from non Lisp code. */ Lisp_Object f_runtime = declare_runtime_imported (); @@ -1644,11 +1649,11 @@ emit_ctxt_code (void) NULL, GCC_JIT_GLOBAL_EXPORTED, gcc_jit_struct_as_type (f_reloc_struct), - "f_reloc"); + IMPORTED_FUNC_RELOC_SYM); /* Exported functions info. */ const char *func_list = SSDATA (FUNCALL1 (comp-ctxt-funcs, Vcomp_ctxt)); - emit_litteral_string_func ("text_exported_funcs", func_list); + emit_litteral_string_func (TEXT_EXPORTED_FUNC_RELOC_SYM, func_list); } @@ -2044,7 +2049,7 @@ define_CHECK_TYPE (void) gcc_jit_block_add_eval (comp.block, NULL, emit_call (intern_c_string ("wrong_type_argument"), - comp.lisp_obj_type, 2, wrong_type_args)); + comp.void_type, 2, wrong_type_args)); gcc_jit_block_end_with_void_return (not_ok_block, NULL); } @@ -2126,7 +2131,7 @@ define_CAR_CDR (void) gcc_jit_block_add_eval (comp.block, NULL, emit_call (intern_c_string ("wrong_type_argument"), - comp.lisp_obj_type, 2, wrong_type_args)); + comp.void_type, 2, wrong_type_args)); gcc_jit_block_end_with_return (comp.block, NULL, emit_lisp_obj_from_ptr (Qnil)); @@ -2819,7 +2824,7 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, Lisp_Object f_reloc = make_vector (fh->count, Qnil); for (ptrdiff_t i = 0; i < fh->count; i++) { - Lisp_Object subr_sym = (XCDR (HASH_VALUE (fh, i))); + Lisp_Object subr_sym = HASH_KEY (fh, i); ASET (f_reloc, i, subr_sym); } emit_litteral_string_func ("text_imported_funcs", @@ -2984,6 +2989,7 @@ static Lisp_Object retrive_litteral_obj (dynlib_handle_ptr handle, const char *str_name) { comp_litt_str_func f = dynlib_sym (handle, str_name); + eassert (f); char *res = f(); return Fread (build_string (res)); } @@ -2991,9 +2997,10 @@ retrive_litteral_obj (dynlib_handle_ptr handle, const char *str_name) static int load_comp_unit (dynlib_handle_ptr handle) { - Lisp_Object *data_relocs = dynlib_sym (handle, "data_relocs"); + /* Imported data. */ + Lisp_Object *data_relocs = dynlib_sym (handle, DATA_RELOC_SYM); - Lisp_Object d_vec = retrive_litteral_obj (handle, "text_data_relocs"); + Lisp_Object d_vec = retrive_litteral_obj (handle, TEXT_DATA_RELOC_SYM); EMACS_UINT d_vec_len = XFIXNUM (Flength (d_vec)); for (EMACS_UINT i = 0; i < d_vec_len; i++) @@ -3002,7 +3009,38 @@ load_comp_unit (dynlib_handle_ptr handle) prevent_gc (data_relocs[i]); } - Lisp_Object func_list = retrive_litteral_obj (handle, "text_exported_funcs"); + /* Imported functions. */ + Lisp_Object (**f_relocs)(void) = + dynlib_sym (handle, IMPORTED_FUNC_RELOC_SYM); + Lisp_Object f_vec = + retrive_litteral_obj (handle, TEXT_IMPORTED_FUNC_RELOC_SYM); + EMACS_UINT f_vec_len = XFIXNUM (Flength (f_vec)); + for (EMACS_UINT i = 0; i < f_vec_len; i++) + { + Lisp_Object f_sym = AREF (f_vec, i); + char *f_str = SSDATA (SYMBOL_NAME (f_sym)); + Lisp_Object subr = Fsymbol_function (f_sym); + if (!NILP (subr)) + { + eassert (SUBRP (subr)); + f_relocs[i] = XSUBR (subr)->function.a0; + } else if (!strcmp (f_str, "wrong_type_argument")) + { + f_relocs[i] = (void *) wrong_type_argument; + } else if (!strcmp (f_str, "helper_PSEUDOVECTOR_TYPEP_XUNTAG")) + { + f_relocs[i] = (void *) helper_PSEUDOVECTOR_TYPEP_XUNTAG; + } else if (!strcmp (f_str, "pure_write_error")) + { + f_relocs[i] = (void *) pure_write_error; + } else + { + error ("Unexpected function relocation %s", f_str); + } + } + + /* Exported functions. */ + Lisp_Object func_list = retrive_litteral_obj (handle, TEXT_EXPORTED_FUNC_RELOC_SYM); while (func_list) { commit 9413488ab4e8752a2fe88ce9f42ca83ffbe5f1a8 Author: Andrea Corallo Date: Sat Aug 31 17:06:45 2019 +0200 reloc emission mechanism seems ok diff --git a/src/comp.c b/src/comp.c index 1a2984bb72..d7e8284545 100644 --- a/src/comp.c +++ b/src/comp.c @@ -149,8 +149,8 @@ typedef struct { Lisp_Object func_blocks; /* blk_name -> gcc_block. */ Lisp_Object func_hash; /* c_f_name -> (gcc_func . subr_name). */ Lisp_Object emitter_dispatcher; - gcc_jit_rvalue *data_relocs; - gcc_jit_lvalue *func_relocs; + gcc_jit_rvalue *data_relocs; /* Synthesized struct holding data relocs. */ + gcc_jit_lvalue *func_relocs; /* Synthesized struct holding func relocs. */ } comp_t; static comp_t comp; @@ -270,53 +270,72 @@ emit_comment (const char *str) str); } -static void -fill_declaration_types (gcc_jit_type **type, gcc_jit_rvalue **args, - unsigned nargs) -{ - /* If args are passed types are extracted from that otherwise assume params */ - /* are all lisp objs. */ - if (args) - for (unsigned i = 0; i < nargs; i++) - type[i] = gcc_jit_rvalue_get_type (args[i]); - else - for (unsigned i = 0; i < nargs; i++) - type[i] = comp.lisp_obj_type; -} - +/* + Declare an imported function. + When nargs is MANY (ptrdiff_t nargs, Lisp_Object *args) signature is assumed. + When types is NULL types is assumed to be all Lisp_Objects. +*/ static gcc_jit_field * declare_imported_func (Lisp_Object subr_sym, gcc_jit_type *ret_type, - unsigned nargs, gcc_jit_rvalue **args) + int nargs, gcc_jit_type **types) { /* Don't want to declare the same function two times. */ eassert (NILP (Fgethash (subr_sym, comp.func_hash, Qnil))); - gcc_jit_type *type[nargs]; - fill_declaration_types (type, args, nargs); + if (nargs == MANY) + { + nargs = 2; + types = alloca (nargs * sizeof (* types)); + types[0] = comp.ptrdiff_type; + types[1] = comp.lisp_obj_type; + } + else if (!types) + { + types = alloca (nargs * sizeof (* types)); + for (unsigned i = 0; i < nargs; i++) + types[i] = comp.lisp_obj_type; + } + + eassert (types); /* String containing the function ptr name. */ - Lisp_Object f_ptr_name - = CALLN (Ffuncall, intern_c_string (STR (comp-c-func-name)), - subr_sym, make_string("R", 1)); - - gcc_jit_type *f_ptr_type - = gcc_jit_context_new_function_ptr_type (comp.ctxt, - NULL, - ret_type, - nargs, - type, - 0); - gcc_jit_field *field - = gcc_jit_context_new_field (comp.ctxt, - NULL, - f_ptr_type, - SSDATA (f_ptr_name)); + Lisp_Object f_ptr_name = + CALLN (Ffuncall, intern_c_string (STR (comp-c-func-name)), + subr_sym, make_string("R", 1)); + + gcc_jit_type *f_ptr_type = + gcc_jit_context_new_function_ptr_type (comp.ctxt, + NULL, + ret_type, + nargs, + types, + 0); + gcc_jit_field *field = + gcc_jit_context_new_field (comp.ctxt, + NULL, + f_ptr_type, + SSDATA (f_ptr_name)); + Lisp_Object value = Fcons (make_mint_ptr (field), subr_sym); Fputhash (subr_sym, value, comp.func_hash); return field; } +static void +fill_declaration_types (gcc_jit_type **type, gcc_jit_rvalue **args, + unsigned nargs) +{ + /* If args are passed types are extracted from that otherwise assume params */ + /* are all lisp objs. */ + if (args) + for (unsigned i = 0; i < nargs; i++) + type[i] = gcc_jit_rvalue_get_type (args[i]); + else + for (unsigned i = 0; i < nargs; i++) + type[i] = comp.lisp_obj_type; +} + static gcc_jit_function * declare_exported_func (const char *f_name, gcc_jit_type *ret_type, unsigned nargs, gcc_jit_rvalue **args) @@ -351,6 +370,9 @@ emit_call (Lisp_Object subr_sym, gcc_jit_type *ret_type, unsigned nargs, gcc_jit_lvalue_access_field (comp.func_relocs, NULL, (gcc_jit_field *) xmint_pointer (XCAR (value))); + if (!f_ptr) + error ("Undeclared function relocation."); + emit_comment (format_string ("calling subr: %s", SSDATA (SYMBOL_NAME (subr_sym)))); return gcc_jit_context_new_call_through_ptr(comp.ctxt, @@ -1523,6 +1545,38 @@ emit_litteral_string_func (const char *str_name, const char *str) gcc_jit_block_end_with_return (block, NULL, res); } +/* + Declare as imported all the functions that are requested from the runtime. + These are either subrs or not. +*/ +static Lisp_Object +declare_runtime_imported (void) +{ + /* For subr imported by the runtime we rely on the standard mechanism in place + for functions imported by lisp code. */ + FUNCALL1 (comp-add-subr-to-relocs, intern_c_string ("1+")); + FUNCALL1 (comp-add-subr-to-relocs, intern_c_string ("1-")); + FUNCALL1 (comp-add-subr-to-relocs, intern_c_string ("+")); + FUNCALL1 (comp-add-subr-to-relocs, intern_c_string ("-")); + + Lisp_Object field_list = Qnil; +#define ADD_IMPORTED(f_name, ret_type, nargs, args) \ + { \ + Lisp_Object name = intern_c_string (f_name); \ + Lisp_Object field = \ + make_mint_ptr (declare_imported_func (name, ret_type, nargs, args)); \ + field_list = Fcons (field, field_list); \ + } while (0) + + ADD_IMPORTED ("wrong_type_argument", comp.void_type, 2, NULL); + gcc_jit_type *args[] = {comp.lisp_obj_type, comp.int_type}; + ADD_IMPORTED ("helper_PSEUDOVECTOR_TYPEP_XUNTAG", comp.bool_type, 2, args); + ADD_IMPORTED ("pure_write_error", comp.void_type, 1, NULL); +#undef ADD_IMPORTED + + return field_list; +} + /* This emit the code needed by every compilation unit to be loaded. */ @@ -1536,49 +1590,61 @@ emit_ctxt_code (void) XFIXNUM (FUNCALL1 (hash-table-count, FUNCALL1 (comp-ctxt-data-relocs-idx, Vcomp_ctxt))); - comp.data_relocs - = gcc_jit_lvalue_as_rvalue( - gcc_jit_context_new_global ( - comp.ctxt, - NULL, - GCC_JIT_GLOBAL_EXPORTED, - gcc_jit_context_new_array_type (comp.ctxt, - NULL, - comp.lisp_obj_type, - d_reloc_len), - "data_relocs")); + comp.data_relocs = + gcc_jit_lvalue_as_rvalue( + gcc_jit_context_new_global ( + comp.ctxt, + NULL, + GCC_JIT_GLOBAL_EXPORTED, + gcc_jit_context_new_array_type (comp.ctxt, + NULL, + comp.lisp_obj_type, + d_reloc_len), + "data_relocs")); emit_litteral_string_func ("text_data_relocs", d_reloc); - /* Imported functions. */ - Lisp_Object f_reloc = FUNCALL1 (comp-ctxt-func-relocs-l, Vcomp_ctxt); - EMACS_UINT f_reloc_len = XFIXNUM (Flength (f_reloc)); + /* Imported functions from non Lisp code. */ + Lisp_Object f_runtime = declare_runtime_imported (); + EMACS_UINT f_reloc_len = XFIXNUM (Flength (f_runtime)); + + /* Imported subrs. */ + Lisp_Object f_subr = FUNCALL1 (comp-ctxt-func-relocs-l, Vcomp_ctxt); + f_reloc_len += XFIXNUM (Flength (f_subr)); + gcc_jit_field *fields[f_reloc_len]; int i = 0; - FOR_EACH_TAIL (f_reloc) + + FOR_EACH_TAIL (f_runtime) { - Lisp_Object subr_sym = XCAR (f_reloc); + fields[i++] = xmint_pointer( XCAR (f_runtime)); + } + + FOR_EACH_TAIL (f_subr) + { + Lisp_Object subr_sym = XCAR (f_subr); Lisp_Object subr = Fsymbol_function (subr_sym); - gcc_jit_field *field - = declare_imported_func (subr_sym, comp.lisp_obj_type, - XFIXNUM (XCDR (Fsubr_arity (subr))), NULL); + Lisp_Object maxarg = XCDR (Fsubr_arity (subr)); + gcc_jit_field *field = + declare_imported_func (subr_sym, comp.lisp_obj_type, + FIXNUMP (maxarg) ? XFIXNUM (maxarg) : MANY, NULL); fields [i++] = field; } eassert (f_reloc_len == i); - gcc_jit_struct *f_reloc_struct - = gcc_jit_context_new_struct_type (comp.ctxt, - NULL, - "function_reloc_struct", - f_reloc_len, - fields); - comp.func_relocs - = gcc_jit_context_new_global ( - comp.ctxt, - NULL, - GCC_JIT_GLOBAL_EXPORTED, - gcc_jit_struct_as_type (f_reloc_struct), - "f_reloc"); + gcc_jit_struct *f_reloc_struct = + gcc_jit_context_new_struct_type (comp.ctxt, + NULL, + "function_reloc_struct", + f_reloc_len, + fields); + comp.func_relocs = + gcc_jit_context_new_global ( + comp.ctxt, + NULL, + GCC_JIT_GLOBAL_EXPORTED, + gcc_jit_struct_as_type (f_reloc_struct), + "f_reloc"); /* Exported functions info. */ const char *func_list = SSDATA (FUNCALL1 (comp-ctxt-funcs, Vcomp_ctxt)); @@ -2332,18 +2398,18 @@ define_PSEUDOVECTORP (void) comp.bool_type, false)); - gcc_jit_rvalue *args[2] = + gcc_jit_rvalue *args[] = { gcc_jit_param_as_rvalue (param[0]), gcc_jit_param_as_rvalue (param[1]) }; comp.block = call_pseudovector_typep_b; /* FIXME use XUNTAG now that's available. */ - gcc_jit_block_end_with_return (call_pseudovector_typep_b - , - NULL, - emit_call (intern_c_string ("helper_PSEUDOVECTOR_TYPEP_XUNTAG"), - comp.bool_type, - 2, - args)); + gcc_jit_block_end_with_return ( + call_pseudovector_typep_b, + NULL, + emit_call (intern_c_string ("helper_PSEUDOVECTOR_TYPEP_XUNTAG"), + comp.bool_type, + 2, + args)); } static void @@ -2731,18 +2797,18 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, emit_ctxt_code (); - /* /\* Define inline functions. *\/ */ - /* define_CAR_CDR(); */ - /* define_PSEUDOVECTORP (); */ - /* define_CHECK_TYPE (); */ - /* define_CHECK_IMPURE (); */ - /* define_bool_to_lisp_obj (); */ - /* define_setcar_setcdr (); */ - /* define_add1_sub1 (); */ - /* define_negate (); */ + /* Define inline functions. */ + define_CAR_CDR(); + define_PSEUDOVECTORP (); + define_CHECK_TYPE (); + define_CHECK_IMPURE (); + define_bool_to_lisp_obj (); + define_setcar_setcdr (); + define_add1_sub1 (); + define_negate (); /* Compile all functions. Can't be done before because the - relocation vectore has to be already compiled. */ + relocation structs has to be already defined. */ struct Lisp_Hash_Table *func_h = XHASH_TABLE (FUNCALL1 (comp-ctxt-funcs-h, Vcomp_ctxt)); for (ptrdiff_t i = 0; i < func_h->count; i++) commit ad5488cad62b04ff1ae28cbbe2a0dcb2af817f27 Author: Andrea Corallo Date: Thu Aug 22 16:00:43 2019 +0200 emit function relocation into structure diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 972c118587..a14438e250 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -80,8 +80,7 @@ "This structure is to serve al relocation creation for the current compiler context." (funcs () :type list - :documentation "Alist lisp-func-name -> c-func-name. -This is build before entering into `comp--compile-ctxt-to-file name'.") + :documentation "Exported functions list.") (funcs-h (make-hash-table) :type hash-table :documentation "lisp-func-name -> comp-func. This is to build the prev field.") @@ -180,6 +179,14 @@ The corresponding index is returned." (push obj (comp-ctxt-data-relocs-l comp-ctxt)) (puthash obj (hash-table-count data-relocs-idx) data-relocs-idx)))) +(defun comp-add-subr-to-relocs (subr-name) + "Keep track of SUBR-NAME into the ctxt relocations. +The corresponding index is returned." + (let ((func-relocs-idx (comp-ctxt-func-relocs-idx comp-ctxt))) + (unless (gethash subr-name func-relocs-idx) + (push subr-name (comp-ctxt-func-relocs-l comp-ctxt)) + (puthash subr-name (hash-table-count func-relocs-idx) func-relocs-idx)))) + (defmacro comp-within-log-buff (&rest body) "Execute BODY while at the end the log-buffer. BODY is evaluate only if `comp-debug' is non nil." @@ -276,10 +283,12 @@ Put PREFIX in front of it." (defun comp-call (func &rest args) "Emit a call for function FUNC with ARGS." + (comp-add-subr-to-relocs func) `(call ,func ,@args)) (defun comp-callref (func &rest args) "Emit a call usign narg abi for FUNC with ARGS." + (comp-add-subr-to-relocs func) `(callref ,func ,@args)) (defun comp-new-frame (size) diff --git a/src/comp.c b/src/comp.c index 5c8106a78e..1a2984bb72 100644 --- a/src/comp.c +++ b/src/comp.c @@ -150,6 +150,7 @@ typedef struct { Lisp_Object func_hash; /* c_f_name -> (gcc_func . subr_name). */ Lisp_Object emitter_dispatcher; gcc_jit_rvalue *data_relocs; + gcc_jit_lvalue *func_relocs; } comp_t; static comp_t comp; @@ -283,7 +284,7 @@ fill_declaration_types (gcc_jit_type **type, gcc_jit_rvalue **args, type[i] = comp.lisp_obj_type; } -static void +static gcc_jit_field * declare_imported_func (Lisp_Object subr_sym, gcc_jit_type *ret_type, unsigned nargs, gcc_jit_rvalue **args) { @@ -305,14 +306,15 @@ declare_imported_func (Lisp_Object subr_sym, gcc_jit_type *ret_type, nargs, type, 0); - gcc_jit_lvalue *f_ptr - = gcc_jit_context_new_global (comp.ctxt, - NULL, - GCC_JIT_GLOBAL_EXPORTED, - f_ptr_type, - SSDATA (f_ptr_name)); - Lisp_Object value = Fcons (make_mint_ptr (f_ptr), subr_sym); + gcc_jit_field *field + = gcc_jit_context_new_field (comp.ctxt, + NULL, + f_ptr_type, + SSDATA (f_ptr_name)); + + Lisp_Object value = Fcons (make_mint_ptr (field), subr_sym); Fputhash (subr_sym, value, comp.func_hash); + return field; } static gcc_jit_function * @@ -343,14 +345,12 @@ emit_call (Lisp_Object subr_sym, gcc_jit_type *ret_type, unsigned nargs, gcc_jit_rvalue **args) { Lisp_Object value = Fgethash (subr_sym, comp.func_hash, Qnil); + eassert (!NILP (value)); - if (NILP (value)) - { - declare_imported_func (subr_sym, ret_type, nargs, args); - value = Fgethash (subr_sym, comp.func_hash, Qnil); - eassert (!NILP (value)); - } - gcc_jit_lvalue *f_ptr = (gcc_jit_lvalue *) xmint_pointer (XCAR (value)); + gcc_jit_lvalue *f_ptr = + gcc_jit_lvalue_access_field (comp.func_relocs, + NULL, + (gcc_jit_field *) xmint_pointer (XCAR (value))); emit_comment (format_string ("calling subr: %s", SSDATA (SYMBOL_NAME (subr_sym)))); return gcc_jit_context_new_call_through_ptr(comp.ctxt, @@ -1529,6 +1529,8 @@ This emit the code needed by every compilation unit to be loaded. static void emit_ctxt_code (void) { + /* Imported objects. */ + const char *d_reloc = SSDATA (FUNCALL1 (comp-ctxt-data-relocs, Vcomp_ctxt)); EMACS_UINT d_reloc_len = XFIXNUM (FUNCALL1 (hash-table-count, @@ -1548,6 +1550,37 @@ emit_ctxt_code (void) emit_litteral_string_func ("text_data_relocs", d_reloc); + /* Imported functions. */ + Lisp_Object f_reloc = FUNCALL1 (comp-ctxt-func-relocs-l, Vcomp_ctxt); + EMACS_UINT f_reloc_len = XFIXNUM (Flength (f_reloc)); + gcc_jit_field *fields[f_reloc_len]; + int i = 0; + FOR_EACH_TAIL (f_reloc) + { + Lisp_Object subr_sym = XCAR (f_reloc); + Lisp_Object subr = Fsymbol_function (subr_sym); + gcc_jit_field *field + = declare_imported_func (subr_sym, comp.lisp_obj_type, + XFIXNUM (XCDR (Fsubr_arity (subr))), NULL); + fields [i++] = field; + } + eassert (f_reloc_len == i); + + gcc_jit_struct *f_reloc_struct + = gcc_jit_context_new_struct_type (comp.ctxt, + NULL, + "function_reloc_struct", + f_reloc_len, + fields); + comp.func_relocs + = gcc_jit_context_new_global ( + comp.ctxt, + NULL, + GCC_JIT_GLOBAL_EXPORTED, + gcc_jit_struct_as_type (f_reloc_struct), + "f_reloc"); + + /* Exported functions info. */ const char *func_list = SSDATA (FUNCALL1 (comp-ctxt-funcs, Vcomp_ctxt)); emit_litteral_string_func ("text_exported_funcs", func_list); } @@ -2658,17 +2691,6 @@ DEFUN ("comp--init-ctxt", Fcomp__init_ctxt, Scomp__init_ctxt, comp.void_ptr_type, pure); - /* Define inline functions. */ - - define_CAR_CDR(); - define_PSEUDOVECTORP (); - define_CHECK_TYPE (); - define_CHECK_IMPURE (); - define_bool_to_lisp_obj (); - define_setcar_setcdr (); - define_add1_sub1 (); - define_negate (); - return Qt; } @@ -2709,6 +2731,16 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, emit_ctxt_code (); + /* /\* Define inline functions. *\/ */ + /* define_CAR_CDR(); */ + /* define_PSEUDOVECTORP (); */ + /* define_CHECK_TYPE (); */ + /* define_CHECK_IMPURE (); */ + /* define_bool_to_lisp_obj (); */ + /* define_setcar_setcdr (); */ + /* define_add1_sub1 (); */ + /* define_negate (); */ + /* Compile all functions. Can't be done before because the relocation vectore has to be already compiled. */ struct Lisp_Hash_Table *func_h commit cf0053a66a8055e05e9842c41f60c2130f4dd642 Author: Andrea Corallo Date: Thu Aug 22 11:40:41 2019 +0200 some renaming diff --git a/src/comp.c b/src/comp.c index 3491d5127d..5c8106a78e 100644 --- a/src/comp.c +++ b/src/comp.c @@ -156,7 +156,6 @@ static comp_t comp; FILE *logfile = NULL; - Lisp_Object helper_save_window_excursion (Lisp_Object v1); @@ -294,10 +293,10 @@ declare_imported_func (Lisp_Object subr_sym, gcc_jit_type *ret_type, gcc_jit_type *type[nargs]; fill_declaration_types (type, args, nargs); - /* String containing the function ptr. */ - Lisp_Object f_ptr_name = CALLN (Ffuncall, intern_c_string (STR (comp-c-func-name)), - subr_sym, make_string("R", 1)); - + /* String containing the function ptr name. */ + Lisp_Object f_ptr_name + = CALLN (Ffuncall, intern_c_string (STR (comp-c-func-name)), + subr_sym, make_string("R", 1)); gcc_jit_type *f_ptr_type = gcc_jit_context_new_function_ptr_type (comp.ctxt, @@ -317,7 +316,7 @@ declare_imported_func (Lisp_Object subr_sym, gcc_jit_type *ret_type, } static gcc_jit_function * -declare_func_exported (const char *f_name, gcc_jit_type *ret_type, +declare_exported_func (const char *f_name, gcc_jit_type *ret_type, unsigned nargs, gcc_jit_rvalue **args) { gcc_jit_type *type[nargs]; @@ -2412,7 +2411,7 @@ compile_function (Lisp_Object func) { EMACS_INT max_args = XFIXNUM (FUNCALL1 (comp-args-max, args)); comp.func - = declare_func_exported (c_name, comp.lisp_obj_type, max_args, NULL); + = declare_exported_func (c_name, comp.lisp_obj_type, max_args, NULL); } else { commit ed2d884872ab18e38ac7d8ba17e1d3a3446029e8 Author: Andrea Corallo Date: Wed Aug 21 23:28:02 2019 +0200 seems to emit all relocs diff --git a/src/comp.c b/src/comp.c index 168db4636b..3491d5127d 100644 --- a/src/comp.c +++ b/src/comp.c @@ -147,7 +147,7 @@ typedef struct { gcc_jit_function *check_type; gcc_jit_function *check_impure; Lisp_Object func_blocks; /* blk_name -> gcc_block. */ - Lisp_Object func_hash; /* f_name -> gcc_func. */ + Lisp_Object func_hash; /* c_f_name -> (gcc_func . subr_name). */ Lisp_Object emitter_dispatcher; gcc_jit_rvalue *data_relocs; } comp_t; @@ -270,19 +270,10 @@ emit_comment (const char *str) str); } -/* - Declare a function. If the function is imported then a function pointer is - stored into comp.func_hash for later reuse and NULL is returned. - If the function is exported the corresponding is returned. -*/ - -static gcc_jit_function * -emit_func_declare (const char *f_name, gcc_jit_type *ret_type, - unsigned nargs, gcc_jit_rvalue **args, - enum gcc_jit_function_kind kind) +static void +fill_declaration_types (gcc_jit_type **type, gcc_jit_rvalue **args, + unsigned nargs) { - gcc_jit_type *type[nargs]; - /* If args are passed types are extracted from that otherwise assume params */ /* are all lisp objs. */ if (args) @@ -291,71 +282,76 @@ emit_func_declare (const char *f_name, gcc_jit_type *ret_type, else for (unsigned i = 0; i < nargs; i++) type[i] = comp.lisp_obj_type; +} - switch (kind) - { - case GCC_JIT_FUNCTION_IMPORTED: - { - gcc_jit_type *f_ptr_type - = gcc_jit_context_new_function_ptr_type (comp.ctxt, - NULL, - ret_type, - nargs, - type, - 0); - gcc_jit_lvalue *f_ptr - = gcc_jit_context_new_global (comp.ctxt, - NULL, - GCC_JIT_GLOBAL_EXPORTED, - f_ptr_type, - f_name); - Lisp_Object key = make_string (f_name, strlen (f_name)); - Lisp_Object value = make_mint_ptr (f_ptr); - /* Don't want to declare the same function two times. */ - eassert (NILP (Fgethash (key, comp.func_hash, Qnil))); - Fputhash (key, value, comp.func_hash); - - return NULL; - } - case GCC_JIT_FUNCTION_EXPORTED: - { - gcc_jit_param *param[nargs]; - for (int i = nargs - 1; i >= 0; i--) - param[i] = gcc_jit_context_new_param(comp.ctxt, - NULL, - type[i], - format_string ("par_%d", i)); - return gcc_jit_context_new_function(comp.ctxt, NULL, - kind, - ret_type, - f_name, - nargs, - param, - 0); - } - default: - eassert (false); - return NULL; - } +static void +declare_imported_func (Lisp_Object subr_sym, gcc_jit_type *ret_type, + unsigned nargs, gcc_jit_rvalue **args) +{ + /* Don't want to declare the same function two times. */ + eassert (NILP (Fgethash (subr_sym, comp.func_hash, Qnil))); + + gcc_jit_type *type[nargs]; + fill_declaration_types (type, args, nargs); + + /* String containing the function ptr. */ + Lisp_Object f_ptr_name = CALLN (Ffuncall, intern_c_string (STR (comp-c-func-name)), + subr_sym, make_string("R", 1)); + + + gcc_jit_type *f_ptr_type + = gcc_jit_context_new_function_ptr_type (comp.ctxt, + NULL, + ret_type, + nargs, + type, + 0); + gcc_jit_lvalue *f_ptr + = gcc_jit_context_new_global (comp.ctxt, + NULL, + GCC_JIT_GLOBAL_EXPORTED, + f_ptr_type, + SSDATA (f_ptr_name)); + Lisp_Object value = Fcons (make_mint_ptr (f_ptr), subr_sym); + Fputhash (subr_sym, value, comp.func_hash); +} + +static gcc_jit_function * +declare_func_exported (const char *f_name, gcc_jit_type *ret_type, + unsigned nargs, gcc_jit_rvalue **args) +{ + gcc_jit_type *type[nargs]; + + fill_declaration_types (type, args, nargs); + + gcc_jit_param *param[nargs]; + for (int i = nargs - 1; i >= 0; i--) + param[i] = gcc_jit_context_new_param(comp.ctxt, + NULL, + type[i], + format_string ("par_%d", i)); + return gcc_jit_context_new_function(comp.ctxt, NULL, + GCC_JIT_GLOBAL_EXPORTED, + ret_type, + f_name, + nargs, + param, + 0); } static gcc_jit_rvalue * emit_call (Lisp_Object subr_sym, gcc_jit_type *ret_type, unsigned nargs, gcc_jit_rvalue **args) { - /* String containing the function ptr. */ - Lisp_Object f_ptr_name = CALLN (Ffuncall, intern_c_string (STR (comp-c-func-name)), - subr_sym, make_string("R", 1)); - Lisp_Object value = Fgethash (f_ptr_name, comp.func_hash, Qnil); + Lisp_Object value = Fgethash (subr_sym, comp.func_hash, Qnil); if (NILP (value)) { - emit_func_declare (SSDATA (f_ptr_name), ret_type, nargs, args, - GCC_JIT_FUNCTION_IMPORTED); - value = Fgethash (f_ptr_name, comp.func_hash, Qnil); + declare_imported_func (subr_sym, ret_type, nargs, args); + value = Fgethash (subr_sym, comp.func_hash, Qnil); eassert (!NILP (value)); } - gcc_jit_lvalue *f_ptr = (gcc_jit_lvalue *) xmint_pointer (value); + gcc_jit_lvalue *f_ptr = (gcc_jit_lvalue *) xmint_pointer (XCAR (value)); emit_comment (format_string ("calling subr: %s", SSDATA (SYMBOL_NAME (subr_sym)))); return gcc_jit_context_new_call_through_ptr(comp.ctxt, @@ -1554,7 +1550,7 @@ emit_ctxt_code (void) emit_litteral_string_func ("text_data_relocs", d_reloc); const char *func_list = SSDATA (FUNCALL1 (comp-ctxt-funcs, Vcomp_ctxt)); - emit_litteral_string_func ("text_funcs", func_list); + emit_litteral_string_func ("text_exported_funcs", func_list); } @@ -2415,9 +2411,8 @@ compile_function (Lisp_Object func) if (!ncall) { EMACS_INT max_args = XFIXNUM (FUNCALL1 (comp-args-max, args)); - comp.func = - emit_func_declare (c_name, comp.lisp_obj_type, max_args, - NULL, GCC_JIT_FUNCTION_EXPORTED); + comp.func + = declare_func_exported (c_name, comp.lisp_obj_type, max_args, NULL); } else { @@ -2645,7 +2640,7 @@ DEFUN ("comp--init-ctxt", Fcomp__init_ctxt, Scomp__init_ctxt, Always reinitialize this cause old function definitions are garbage collected by libgccjit when the ctxt is released. */ - comp.func_hash = CALLN (Fmake_hash_table, QCtest, Qequal); + comp.func_hash = CALLN (Fmake_hash_table); /* Define data structures. */ @@ -2722,7 +2717,18 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, for (ptrdiff_t i = 0; i < func_h->count; i++) compile_function (HASH_VALUE (func_h, i)); - /* FIXME use format_String here */ + /* FIXME wrap me */ + struct Lisp_Hash_Table *fh = XHASH_TABLE (comp.func_hash); + Lisp_Object f_reloc = make_vector (fh->count, Qnil); + for (ptrdiff_t i = 0; i < fh->count; i++) + { + Lisp_Object subr_sym = (XCDR (HASH_VALUE (fh, i))); + ASET (f_reloc, i, subr_sym); + } + emit_litteral_string_func ("text_imported_funcs", + (SSDATA (Fprin1_to_string (f_reloc, Qnil)))); + + /* FIXME use format_string here */ if (COMP_DEBUG) { AUTO_STRING (dot_c, ".c"); @@ -2899,7 +2905,7 @@ load_comp_unit (dynlib_handle_ptr handle) prevent_gc (data_relocs[i]); } - Lisp_Object func_list = retrive_litteral_obj (handle, "text_funcs"); + Lisp_Object func_list = retrive_litteral_obj (handle, "text_exported_funcs"); while (func_list) { commit d34eb7a39f15524dd13681864be14f85d15b4a0b Author: Andrea Corallo Date: Wed Aug 21 21:20:27 2019 +0200 reloc fist simple func diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 26a7373aa2..972c118587 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -213,12 +213,12 @@ BODY is evaluate only if `comp-debug' is non nil." ;;; spill-lap pass specific code. -(defun comp-c-func-name (symbol-function prefix) - "Given SYMBOL-FUNCTION return a name suitable for the native code. +(defun comp-c-func-name (symbol prefix) + "Given SYMBOL return a name suitable for the native code. Put PREFIX in front of it." ;; Unfortunatelly not all symbol names are valid as C function names... ;; Nassi's algorithm here: - (let* ((orig-name (symbol-name symbol-function)) + (let* ((orig-name (symbol-name symbol)) (crypted (cl-loop with str = (make-string (* 2 (length orig-name)) 0) for j from 0 by 2 for i across orig-name @@ -276,11 +276,11 @@ Put PREFIX in front of it." (defun comp-call (func &rest args) "Emit a call for function FUNC with ARGS." - `(call (,func . ,(comp-c-func-name func "R")) ,@args)) + `(call ,func ,@args)) (defun comp-callref (func &rest args) "Emit a call usign narg abi for FUNC with ARGS." - `(callref (,func . ,(comp-c-func-name func "R")) ,@args)) + `(callref ,func ,@args)) (defun comp-new-frame (size) "Return a clean frame of meta variables of size SIZE." diff --git a/src/comp.c b/src/comp.c index acf02e7c7c..168db4636b 100644 --- a/src/comp.c +++ b/src/comp.c @@ -58,7 +58,7 @@ along with GNU Emacs. If not, see . */ XCAR (XCDR (XCDR (XCDR (x)))) #define FUNCALL1(fun, arg) \ - CALLN (Ffuncall, intern (STR(fun)), arg) + CALLN (Ffuncall, intern_c_string (STR(fun)), arg) #define DECL_BLOCK(name, func) \ gcc_jit_block *(name) = \ @@ -270,15 +270,17 @@ emit_comment (const char *str) str); } -/* Declare a function with all args being Lisp_Object and returning a - Lisp_Object. */ +/* + Declare a function. If the function is imported then a function pointer is + stored into comp.func_hash for later reuse and NULL is returned. + If the function is exported the corresponding is returned. +*/ static gcc_jit_function * emit_func_declare (const char *f_name, gcc_jit_type *ret_type, unsigned nargs, gcc_jit_rvalue **args, - enum gcc_jit_function_kind kind, bool reusable) + enum gcc_jit_function_kind kind) { - gcc_jit_param *param[nargs]; gcc_jit_type *type[nargs]; /* If args are passed types are extracted from that otherwise assume params */ @@ -290,59 +292,81 @@ emit_func_declare (const char *f_name, gcc_jit_type *ret_type, for (unsigned i = 0; i < nargs; i++) type[i] = comp.lisp_obj_type; - for (int i = nargs - 1; i >= 0; i--) - param[i] = gcc_jit_context_new_param(comp.ctxt, - NULL, - type[i], - format_string ("par_%d", i)); - - gcc_jit_function *func = - gcc_jit_context_new_function(comp.ctxt, NULL, - kind, - ret_type, - f_name, - nargs, - param, - 0); - - if (reusable) + switch (kind) { - Lisp_Object key = make_string (f_name, strlen (f_name)); - Lisp_Object value = make_mint_ptr (func); - /* Don't want to declare the same function two times. */ - eassert (NILP (Fgethash (key, comp.func_hash, Qnil))); - - Fputhash (key, value, comp.func_hash); + case GCC_JIT_FUNCTION_IMPORTED: + { + gcc_jit_type *f_ptr_type + = gcc_jit_context_new_function_ptr_type (comp.ctxt, + NULL, + ret_type, + nargs, + type, + 0); + gcc_jit_lvalue *f_ptr + = gcc_jit_context_new_global (comp.ctxt, + NULL, + GCC_JIT_GLOBAL_EXPORTED, + f_ptr_type, + f_name); + Lisp_Object key = make_string (f_name, strlen (f_name)); + Lisp_Object value = make_mint_ptr (f_ptr); + /* Don't want to declare the same function two times. */ + eassert (NILP (Fgethash (key, comp.func_hash, Qnil))); + Fputhash (key, value, comp.func_hash); + + return NULL; + } + case GCC_JIT_FUNCTION_EXPORTED: + { + gcc_jit_param *param[nargs]; + for (int i = nargs - 1; i >= 0; i--) + param[i] = gcc_jit_context_new_param(comp.ctxt, + NULL, + type[i], + format_string ("par_%d", i)); + return gcc_jit_context_new_function(comp.ctxt, NULL, + kind, + ret_type, + f_name, + nargs, + param, + 0); + } + default: + eassert (false); + return NULL; } - - return func; } static gcc_jit_rvalue * -emit_call (const char *f_name, gcc_jit_type *ret_type, unsigned nargs, +emit_call (Lisp_Object subr_sym, gcc_jit_type *ret_type, unsigned nargs, gcc_jit_rvalue **args) { - Lisp_Object key = make_string (f_name, strlen (f_name)); - Lisp_Object value = Fgethash (key, comp.func_hash, Qnil); + /* String containing the function ptr. */ + Lisp_Object f_ptr_name = CALLN (Ffuncall, intern_c_string (STR (comp-c-func-name)), + subr_sym, make_string("R", 1)); + Lisp_Object value = Fgethash (f_ptr_name, comp.func_hash, Qnil); if (NILP (value)) { - emit_func_declare (f_name, ret_type, nargs, args, - GCC_JIT_FUNCTION_IMPORTED, true); - value = Fgethash (key, comp.func_hash, Qnil); + emit_func_declare (SSDATA (f_ptr_name), ret_type, nargs, args, + GCC_JIT_FUNCTION_IMPORTED); + value = Fgethash (f_ptr_name, comp.func_hash, Qnil); eassert (!NILP (value)); } - gcc_jit_function *func = (gcc_jit_function *) xmint_pointer (value); - - return gcc_jit_context_new_call(comp.ctxt, - NULL, - func, - nargs, - args); + gcc_jit_lvalue *f_ptr = (gcc_jit_lvalue *) xmint_pointer (value); + emit_comment (format_string ("calling subr: %s", + SSDATA (SYMBOL_NAME (subr_sym)))); + return gcc_jit_context_new_call_through_ptr(comp.ctxt, + NULL, + gcc_jit_lvalue_as_rvalue (f_ptr), + nargs, + args); } static gcc_jit_rvalue * -emit_call_ref (const char *f_name, unsigned nargs, +emit_call_ref (Lisp_Object subr_sym, unsigned nargs, gcc_jit_lvalue *base_arg) { gcc_jit_rvalue *args[] = @@ -350,7 +374,7 @@ emit_call_ref (const char *f_name, unsigned nargs, comp.ptrdiff_type, nargs), gcc_jit_lvalue_get_address (base_arg, NULL) }; - return emit_call (f_name, comp.lisp_obj_type, 2, args); + return emit_call (subr_sym, comp.lisp_obj_type, 2, args); } /* Close current basic block emitting a conditional. */ @@ -1011,7 +1035,8 @@ emit_set_internal (Lisp_Object args) gcc_args[3] = gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.int_type, SET_INTERNAL_SET); - return emit_call ("set_internal", comp.void_type , 4, gcc_args); + return emit_call (intern_c_string ("set_internal"), comp.void_type , 4, + gcc_args); } /* This is for a regular function with arguments as m-var. */ @@ -1020,7 +1045,7 @@ static gcc_jit_rvalue * emit_simple_limple_call (Lisp_Object args, gcc_jit_type *ret_type) { int i = 0; - char *callee = (char *) SDATA (SYMBOL_NAME (FIRST (args))); + Lisp_Object callee = FIRST (args); args = XCDR (args); ptrdiff_t nargs = list_length (args); gcc_jit_rvalue *gcc_args[nargs]; @@ -1054,7 +1079,6 @@ static gcc_jit_rvalue * emit_limple_call (Lisp_Object insn) { Lisp_Object callee_sym = FIRST (insn); - char *callee = (char *) SDATA (SYMBOL_NAME (callee_sym)); Lisp_Object emitter = Fgethash (callee_sym, comp.emitter_dispatcher, Qnil); if (!NILP (emitter)) @@ -1062,12 +1086,8 @@ emit_limple_call (Lisp_Object insn) gcc_jit_rvalue * (* emitter_ptr) (Lisp_Object) = xmint_pointer (emitter); return emitter_ptr (insn); } - else if (callee[0] == 'F') - { - return emit_simple_limple_call_lisp_ret (insn); - } - error ("LIMPLE call is inconsistent"); + return emit_simple_limple_call_lisp_ret (insn); } static gcc_jit_rvalue * @@ -1075,7 +1095,7 @@ emit_limple_call_ref (Lisp_Object insn) { /* Ex: (callref Fplus 2 0). */ - char *callee = (char *) SDATA (SYMBOL_NAME (FIRST (insn))); + Lisp_Object callee = FIRST (insn); EMACS_UINT nargs = XFIXNUM (SECOND (insn)); EMACS_UINT base_ptr = XFIXNUM (THIRD (insn)); return emit_call_ref (callee, nargs, comp.frame[base_ptr]); @@ -1106,7 +1126,7 @@ emit_limple_push_handler (gcc_jit_rvalue *handler, gcc_jit_rvalue *handler_type, comp.block, NULL, c, - emit_call ("push_handler", comp.handler_ptr_type, 2, args)); + emit_call (intern_c_string ("push_handler"), comp.handler_ptr_type, 2, args)); args[0] = gcc_jit_lvalue_get_address ( @@ -1118,9 +1138,9 @@ emit_limple_push_handler (gcc_jit_rvalue *handler, gcc_jit_rvalue *handler_type, gcc_jit_rvalue *res; #ifdef HAVE__SETJMP - res = emit_call ("_setjmp", comp.int_type, 1, args); + res = emit_call (intern_c_string ("_setjmp"), comp.int_type, 1, args); #else - res = emit_call ("setjmp", comp.int_type, 1, args); + res = emit_call (intern_c_string ("setjmp"), comp.int_type, 1, args); #endif emit_cond_jump (res, handler_bb, guarded_bb); @@ -1322,7 +1342,7 @@ emit_limple_insn (Lisp_Object insn) n), gcc_jit_lvalue_as_rvalue (args) }; - res = emit_call ("Flist", comp.lisp_obj_type, 2, + res = emit_call (Qlist, comp.lisp_obj_type, 2, list_args); gcc_jit_block_add_assignment (comp.block, @@ -1929,7 +1949,7 @@ define_CHECK_TYPE (void) gcc_jit_block_add_eval (comp.block, NULL, - emit_call ("wrong_type_argument", + emit_call (intern_c_string ("wrong_type_argument"), comp.lisp_obj_type, 2, wrong_type_args)); gcc_jit_block_end_with_void_return (not_ok_block, NULL); @@ -2011,7 +2031,7 @@ define_CAR_CDR (void) gcc_jit_block_add_eval (comp.block, NULL, - emit_call ("wrong_type_argument", + emit_call (intern_c_string ("wrong_type_argument"), comp.lisp_obj_type, 2, wrong_type_args)); gcc_jit_block_end_with_return (comp.block, NULL, @@ -2098,7 +2118,7 @@ define_add1_sub1 (void) gcc_jit_function *func[2]; char const *f_name[] = {"add1", "sub1"}; - char const *fall_back_func[] = {"Fadd1", "Fsub1"}; + char const *fall_back_func[] = {"1+", "1-"}; gcc_jit_rvalue *compare[] = { comp.most_positive_fixnum, comp.most_negative_fixnum }; enum gcc_jit_binary_op op[] = @@ -2160,7 +2180,7 @@ define_add1_sub1 (void) emit_make_fixnum (inline_res)); comp.block = fcall_block; - gcc_jit_rvalue *call_res = emit_call (fall_back_func[i], + gcc_jit_rvalue *call_res = emit_call (intern_c_string (fall_back_func[i]), comp.lisp_obj_type, 1, &n); gcc_jit_block_end_with_return (fcall_block, NULL, @@ -2234,7 +2254,7 @@ define_negate (void) emit_make_fixnum (inline_res)); comp.block = fcall_block; - gcc_jit_rvalue *call_res = emit_call_ref ("Fminus", 1, n); + gcc_jit_rvalue *call_res = emit_call_ref (Qminus, 1, n); gcc_jit_block_end_with_return (fcall_block, NULL, call_res); @@ -2292,7 +2312,7 @@ define_PSEUDOVECTORP (void) gcc_jit_block_end_with_return (call_pseudovector_typep_b , NULL, - emit_call ("helper_PSEUDOVECTOR_TYPEP_XUNTAG", + emit_call (intern_c_string ("helper_PSEUDOVECTOR_TYPEP_XUNTAG"), comp.bool_type, 2, args)); @@ -2337,7 +2357,7 @@ define_CHECK_IMPURE (void) comp.block = err_block; gcc_jit_block_add_eval (comp.block, NULL, - emit_call ("pure_write_error", + emit_call (intern_c_string ("pure_write_error"), comp.void_type, 1, &pure_write_error_arg)); @@ -2397,7 +2417,7 @@ compile_function (Lisp_Object func) EMACS_INT max_args = XFIXNUM (FUNCALL1 (comp-args-max, args)); comp.func = emit_func_declare (c_name, comp.lisp_obj_type, max_args, - NULL, GCC_JIT_FUNCTION_EXPORTED, false); + NULL, GCC_JIT_FUNCTION_EXPORTED); } else { @@ -2702,6 +2722,7 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, for (ptrdiff_t i = 0; i < func_h->count; i++) compile_function (HASH_VALUE (func_h, i)); + /* FIXME use format_String here */ if (COMP_DEBUG) { AUTO_STRING (dot_c, ".c"); commit 620794aa93107115b52f3622c7b6934ebc3fc8ac Author: Andrea Corallo Date: Wed Aug 21 12:17:56 2019 +0200 emit function relocation name from comp.el diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 3452fed916..26a7373aa2 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -180,14 +180,6 @@ The corresponding index is returned." (push obj (comp-ctxt-data-relocs-l comp-ctxt)) (puthash obj (hash-table-count data-relocs-idx) data-relocs-idx)))) -(defun comp-add-subr-to-relocs (subr-name) - "Keep track of SUBR-NAME into the ctxt relocations. -The corresponding index is returned." - (let ((func-relocs-idx (comp-ctxt-func-relocs-idx comp-ctxt))) - (unless (gethash subr-name func-relocs-idx) - (push subr-name (comp-ctxt-func-relocs-l comp-ctxt)) - (puthash subr-name (hash-table-count func-relocs-idx) func-relocs-idx)))) - (defmacro comp-within-log-buff (&rest body) "Execute BODY while at the end the log-buffer. BODY is evaluate only if `comp-debug' is non nil." @@ -221,8 +213,9 @@ BODY is evaluate only if `comp-debug' is non nil." ;;; spill-lap pass specific code. -(defun comp-c-func-name (symbol-function) - "Given SYMBOL-FUNCTION return a name suitable for the native code." +(defun comp-c-func-name (symbol-function prefix) + "Given SYMBOL-FUNCTION return a name suitable for the native code. +Put PREFIX in front of it." ;; Unfortunatelly not all symbol names are valid as C function names... ;; Nassi's algorithm here: (let* ((orig-name (symbol-name symbol-function)) @@ -237,7 +230,7 @@ BODY is evaluate only if `comp-debug' is non nil." "-" "_" orig-name)) (human-readable (replace-regexp-in-string (rx (not (any "0-9a-z_"))) "" human-readable))) - (concat "F" crypted "_" human-readable))) + (concat prefix crypted "_" human-readable))) (defun comp-decrypt-lambda-list (x) "Decript lambda list X." @@ -281,15 +274,13 @@ BODY is evaluate only if `comp-debug' is non nil." ;; (cl-every #'identity (mapcar #'comp-mvar-const-vld args))) ;; (apply f (mapcar #'comp-mvar-constant args))))) -(defun comp-call (&rest args) - "Emit a call for ARGS." - (comp-add-subr-to-relocs (car args)) - `(call ,@args)) +(defun comp-call (func &rest args) + "Emit a call for function FUNC with ARGS." + `(call (,func . ,(comp-c-func-name func "R")) ,@args)) -(defun comp-callref (&rest args) - "Emit a call usign narg abi for ARGS." - (comp-add-subr-to-relocs (car args)) - `(callref ,@args)) +(defun comp-callref (func &rest args) + "Emit a call usign narg abi for FUNC with ARGS." + `(callref (,func . ,(comp-c-func-name func "R")) ,@args)) (defun comp-new-frame (size) "Return a clean frame of meta variables of size SIZE." @@ -876,7 +867,8 @@ the annotation emission." (let ((func (make-comp-func :symbol-name func-symbol-name :func f :c-func-name (comp-c-func-name - func-symbol-name))) + func-symbol-name + "F"))) (comp-ctxt (make-comp-ctxt))) (mapc (lambda (pass) (funcall pass func)) commit 5e06f2fc31a12012d73ef741715a68e47f0c3a09 Author: Andrea Corallo Date: Mon Aug 19 18:22:26 2019 +0200 some clean-up into comp.el diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 82e9e8a620..3452fed916 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -54,7 +54,7 @@ comp-limplify) "Passes to be executed in order.") -(defconst comp-known-ret-types '((Fcons . cons)) +(defconst comp-known-ret-types '((cons . cons)) "Alist used for type propagation.") (defconst comp-mostly-pure-funcs @@ -92,7 +92,7 @@ This is build before entering into `comp--compile-ctxt-to-file name'.") :documentation "Constant objects used by functions.") (data-relocs-idx (make-hash-table :test #'equal) :type hash-table :documentation "Obj -> position into data-relocs.") - (func-relocs () :type list + (func-relocs-l () :type list :documentation "Native functions imported.") (func-relocs-idx (make-hash-table :test #'equal) :type hash-table :documentation "Obj -> position into func-relocs.")) @@ -183,10 +183,10 @@ The corresponding index is returned." (defun comp-add-subr-to-relocs (subr-name) "Keep track of SUBR-NAME into the ctxt relocations. The corresponding index is returned." - (let ((funcs-relocs-idx (comp-ctxt-funcs-relocs-idx comp-ctxt))) - (unless (gethash subr-name funcs-relocs-idx) - (push subr-name (comp-ctxt-funcs-relocs-l comp-ctxt)) - (puthash subr-name (hash-table-count funcs-relocs-idx) funcs-relocs-idx)))) + (let ((func-relocs-idx (comp-ctxt-func-relocs-idx comp-ctxt))) + (unless (gethash subr-name func-relocs-idx) + (push subr-name (comp-ctxt-func-relocs-l comp-ctxt)) + (puthash subr-name (hash-table-count func-relocs-idx) func-relocs-idx)))) (defmacro comp-within-log-buff (&rest body) "Execute BODY while at the end the log-buffer. @@ -458,12 +458,12 @@ If NEGATED non nil negate the tested condition." (defun comp-limplify-listn (n) "Limplify list N." (comp-with-sp (+ (comp-sp) n -1) - (comp-emit-set-call (comp-call 'Fcons + (comp-emit-set-call (comp-call 'cons (comp-slot) (make-comp-mvar :constant nil)))) (cl-loop for sp from (+ (comp-sp) n -2) downto (comp-sp) do (comp-with-sp sp - (comp-emit-set-call (comp-call 'Fcons + (comp-emit-set-call (comp-call 'cons (comp-slot) (comp-slot-next)))))) @@ -593,8 +593,8 @@ the annotation emission." (byte-stack-ref (comp-copy-slot (- (comp-sp) arg 1))) (byte-varref - (comp-emit-set-call (comp-call 'Fsymbol_value (make-comp-mvar - :constant arg)))) + (comp-emit-set-call (comp-call 'symbol_value (make-comp-mvar + :constant arg)))) (byte-varset (comp-emit (comp-call 'set_internal (make-comp-mvar :constant arg) @@ -621,7 +621,7 @@ the annotation emission." (byte-listp auto) (byte-eq auto) (byte-memq auto) - (byte-not null Fnull) + (byte-not null) (byte-car auto) (byte-cdr auto) (byte-cons auto) @@ -643,25 +643,25 @@ the annotation emission." (byte-get auto) (byte-substring auto) (byte-concat2 - (comp-emit-set-call (comp-callref 'Fconcat 2 (comp-sp)))) + (comp-emit-set-call (comp-callref 'concat 2 (comp-sp)))) (byte-concat3 - (comp-emit-set-call (comp-callref 'Fconcat 3 (comp-sp)))) + (comp-emit-set-call (comp-callref 'concat 3 (comp-sp)))) (byte-concat4 - (comp-emit-set-call (comp-callref 'Fconcat 4 (comp-sp)))) - (byte-sub1 1- Fsub1) - (byte-add1 1+ Fadd1) - (byte-eqlsign = Feqlsign) - (byte-gtr > Fgtr) - (byte-lss < Flss) - (byte-leq <= Fleq) - (byte-geq >= Fgeq) - (byte-diff - Fminus) + (comp-emit-set-call (comp-callref 'concat 4 (comp-sp)))) + (byte-sub1 1-) + (byte-add1 1+) + (byte-eqlsign =) + (byte-gtr >) + (byte-lss <) + (byte-leq <=) + (byte-geq >=) + (byte-diff -) (byte-negate (comp-emit-set-call (comp-call 'negate (comp-slot)))) - (byte-plus + Fplus) + (byte-plus +) (byte-max auto) (byte-min auto) - (byte-mult * Ftimes) + (byte-mult *) (byte-point auto) (byte-goto-char auto) (byte-insert auto) @@ -669,10 +669,10 @@ the annotation emission." (byte-point-min auto) (byte-char-after auto) (byte-following-char auto) - (byte-preceding-char preceding-char Fprevious_char) + (byte-preceding-char preceding-char) (byte-current-column auto) (byte-indent-to - (comp-emit-set-call (comp-call 'Findent_to + (comp-emit-set-call (comp-call 'indent_to (comp-slot) (make-comp-mvar :constant nil)))) (byte-scan-buffer-OBSOLETE) @@ -695,11 +695,11 @@ the annotation emission." (byte-buffer-substring auto) (byte-delete-region auto) (byte-narrow-to-region - (comp-emit-set-call (comp-call 'Fnarrow_to_region + (comp-emit-set-call (comp-call 'narrow_to_region (comp-slot) (comp-slot-next)))) (byte-widen - (comp-emit-set-call (comp-call 'Fwiden))) + (comp-emit-set-call (comp-call 'widen))) (byte-end-of-line auto) (byte-constant2) ;; TODO (byte-goto @@ -739,8 +739,8 @@ the annotation emission." (byte-match-end auto) (byte-upcase auto) (byte-downcase auto) - (byte-string= string-equal Fstring_equal) - (byte-string< string-lessp Fstring_lessp) + (byte-string= string-equal) + (byte-string< string-lessp) (byte-equal auto) (byte-nthcdr auto) (byte-elt auto) @@ -752,19 +752,19 @@ the annotation emission." (byte-car-safe auto) (byte-cdr-safe auto) (byte-nconc auto) - (byte-quo / Fquo) - (byte-rem % Frem) + (byte-quo /) + (byte-rem %) (byte-numberp auto) (byte-integerp auto) (byte-listN (comp-stack-adjust (- 1 arg)) - (comp-emit-set-call (comp-callref 'Flist arg (comp-sp)))) + (comp-emit-set-call (comp-callref 'list arg (comp-sp)))) (byte-concatN (comp-stack-adjust (- 1 arg)) - (comp-emit-set-call (comp-callref 'Fconcat arg (comp-sp)))) + (comp-emit-set-call (comp-callref 'concat arg (comp-sp)))) (byte-insertN (comp-stack-adjust (- 1 arg)) - (comp-emit-set-call (comp-callref 'Finsert arg (comp-sp)))) + (comp-emit-set-call (comp-callref 'insert arg (comp-sp)))) (byte-stack-set (comp-with-sp (1+ (comp-sp)) (comp-copy-slot (comp-sp) (- (comp-sp) arg)))) commit 8bf2e4e282ff3c0661ebea70e574cce16bdcc356 Author: Andrea Corallo Date: Mon Aug 19 17:59:20 2019 +0200 add and call comp-add-subr-to-relocs diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 32fc1866c0..82e9e8a620 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -173,13 +173,21 @@ LIMPLE basic block.") (defun comp-add-const-to-relocs (obj) - "Keep track of OBJ into relocations. -The corresponding index into it is returned." + "Keep track of OBJ into the ctxt relocations. +The corresponding index is returned." (let ((data-relocs-idx (comp-ctxt-data-relocs-idx comp-ctxt))) (unless (gethash obj data-relocs-idx) (push obj (comp-ctxt-data-relocs-l comp-ctxt)) (puthash obj (hash-table-count data-relocs-idx) data-relocs-idx)))) +(defun comp-add-subr-to-relocs (subr-name) + "Keep track of SUBR-NAME into the ctxt relocations. +The corresponding index is returned." + (let ((funcs-relocs-idx (comp-ctxt-funcs-relocs-idx comp-ctxt))) + (unless (gethash subr-name funcs-relocs-idx) + (push subr-name (comp-ctxt-funcs-relocs-l comp-ctxt)) + (puthash subr-name (hash-table-count funcs-relocs-idx) funcs-relocs-idx)))) + (defmacro comp-within-log-buff (&rest body) "Execute BODY while at the end the log-buffer. BODY is evaluate only if `comp-debug' is non nil." @@ -273,6 +281,16 @@ BODY is evaluate only if `comp-debug' is non nil." ;; (cl-every #'identity (mapcar #'comp-mvar-const-vld args))) ;; (apply f (mapcar #'comp-mvar-constant args))))) +(defun comp-call (&rest args) + "Emit a call for ARGS." + (comp-add-subr-to-relocs (car args)) + `(call ,@args)) + +(defun comp-callref (&rest args) + "Emit a call usign narg abi for ARGS." + (comp-add-subr-to-relocs (car args)) + `(callref ,@args)) + (defun comp-new-frame (size) "Return a clean frame of meta variables of size SIZE." (let ((v (make-vector size nil))) @@ -351,7 +369,7 @@ SP-DELTA is the stack adjustment." `(let* ((subr-name ',subr-name) (slots (cl-loop for i from 0 below ,maxarg collect (comp-slot-n (+ i (comp-sp)))))) - (comp-emit-set-call `(call ,subr-name ,@slots))))))) + (comp-emit-set-call (apply #'comp-call (cons subr-name slots)))))))) (defun comp-copy-slot (src-n &optional dst-n) "Set slot number DST-N to slot number SRC-N as source. @@ -440,14 +458,14 @@ If NEGATED non nil negate the tested condition." (defun comp-limplify-listn (n) "Limplify list N." (comp-with-sp (+ (comp-sp) n -1) - (comp-emit-set-call `(call Fcons - ,(comp-slot) - ,(make-comp-mvar :constant nil)))) + (comp-emit-set-call (comp-call 'Fcons + (comp-slot) + (make-comp-mvar :constant nil)))) (cl-loop for sp from (+ (comp-sp) n -2) downto (comp-sp) do (comp-with-sp sp - (comp-emit-set-call `(call Fcons - ,(comp-slot) - ,(comp-slot-next)))))) + (comp-emit-set-call (comp-call 'Fcons + (comp-slot) + (comp-slot-next)))))) (defun comp-new-block-sym () "Return a symbol naming the next new basic block." @@ -575,21 +593,21 @@ the annotation emission." (byte-stack-ref (comp-copy-slot (- (comp-sp) arg 1))) (byte-varref - (comp-emit-set-call `(call Fsymbol_value ,(make-comp-mvar - :constant arg)))) + (comp-emit-set-call (comp-call 'Fsymbol_value (make-comp-mvar + :constant arg)))) (byte-varset - (comp-emit `(call set_internal - ,(make-comp-mvar :constant arg) - ,(comp-slot)))) + (comp-emit (comp-call 'set_internal + (make-comp-mvar :constant arg) + (comp-slot)))) (byte-varbind ;; Verify - (comp-emit `(call specbind - ,(make-comp-mvar :constant arg) - ,(comp-slot-next)))) + (comp-emit (comp-call 'specbind + (make-comp-mvar :constant arg) + (comp-slot-next)))) (byte-call (comp-emit-funcall arg)) (byte-unbind - (comp-emit `(call helper_unbind_n - ,(make-comp-mvar :constant arg)))) + (comp-emit (comp-call 'helper_unbind_n + (make-comp-mvar :constant arg)))) (byte-pophandler (comp-emit '(pop-handler))) (byte-pushconditioncase @@ -625,11 +643,11 @@ the annotation emission." (byte-get auto) (byte-substring auto) (byte-concat2 - (comp-emit-set-call `(callref Fconcat 2 ,(comp-sp)))) + (comp-emit-set-call (comp-callref 'Fconcat 2 (comp-sp)))) (byte-concat3 - (comp-emit-set-call `(callref Fconcat 3 ,(comp-sp)))) + (comp-emit-set-call (comp-callref 'Fconcat 3 (comp-sp)))) (byte-concat4 - (comp-emit-set-call `(callref Fconcat 4 ,(comp-sp)))) + (comp-emit-set-call (comp-callref 'Fconcat 4 (comp-sp)))) (byte-sub1 1- Fsub1) (byte-add1 1+ Fadd1) (byte-eqlsign = Feqlsign) @@ -639,7 +657,7 @@ the annotation emission." (byte-geq >= Fgeq) (byte-diff - Fminus) (byte-negate - (comp-emit-set-call `(call negate ,(comp-slot)))) + (comp-emit-set-call (comp-call 'negate (comp-slot)))) (byte-plus + Fplus) (byte-max auto) (byte-min auto) @@ -654,9 +672,9 @@ the annotation emission." (byte-preceding-char preceding-char Fprevious_char) (byte-current-column auto) (byte-indent-to - (comp-emit-set-call `(call Findent_to - ,(comp-slot) - ,(make-comp-mvar :constant nil)))) + (comp-emit-set-call (comp-call 'Findent_to + (comp-slot) + (make-comp-mvar :constant nil)))) (byte-scan-buffer-OBSOLETE) (byte-eolp auto) (byte-eobp auto) @@ -665,7 +683,7 @@ the annotation emission." (byte-current-buffer auto) (byte-set-buffer auto) (byte-save-current-buffer - (comp-emit '(call record_unwind_current_buffer))) + (comp-emit (comp-call 'record_unwind_current_buffer))) (byte-set-mark-OBSOLETE) (byte-interactive-p-OBSOLETE) (byte-forward-char auto) @@ -677,11 +695,11 @@ the annotation emission." (byte-buffer-substring auto) (byte-delete-region auto) (byte-narrow-to-region - (comp-emit-set-call `(call Fnarrow_to_region - ,(comp-slot) - ,(comp-slot-next)))) + (comp-emit-set-call (comp-call 'Fnarrow_to_region + (comp-slot) + (comp-slot-next)))) (byte-widen - (comp-emit-set-call '(call Fwiden))) + (comp-emit-set-call (comp-call 'Fwiden))) (byte-end-of-line auto) (byte-constant2) ;; TODO (byte-goto @@ -705,13 +723,13 @@ the annotation emission." (byte-dup (comp-copy-slot (1- (comp-sp)))) (byte-save-excursion - (comp-emit '(call record_unwind_protect_excursion))) + (comp-emit (comp-call 'record_unwind_protect_excursion))) (byte-save-window-excursion-OBSOLETE) (byte-save-restriction - '(call helper-save-restriction)) + (comp-call 'helper-save-restriction)) (byte-catch) ;; Obsolete (byte-unwind-protect - (comp-emit `(call helper_unwind_protect ,(comp-slot-next)))) + (comp-emit (comp-call 'helper_unwind_protect (comp-slot-next)))) (byte-condition-case) ;; Obsolete (byte-temp-output-buffer-setup-OBSOLETE) (byte-temp-output-buffer-show-OBSOLETE) @@ -740,13 +758,13 @@ the annotation emission." (byte-integerp auto) (byte-listN (comp-stack-adjust (- 1 arg)) - (comp-emit-set-call `(callref Flist ,arg ,(comp-sp)))) + (comp-emit-set-call (comp-callref 'Flist arg (comp-sp)))) (byte-concatN (comp-stack-adjust (- 1 arg)) - (comp-emit-set-call `(callref Fconcat ,arg ,(comp-sp)))) + (comp-emit-set-call (comp-callref 'Fconcat arg (comp-sp)))) (byte-insertN (comp-stack-adjust (- 1 arg)) - (comp-emit-set-call `(callref Finsert ,arg ,(comp-sp)))) + (comp-emit-set-call (comp-callref 'Finsert arg (comp-sp)))) (byte-stack-set (comp-with-sp (1+ (comp-sp)) (comp-copy-slot (comp-sp) (- (comp-sp) arg)))) commit 5ebc3fc47cfefb9f6726e9308f153c0df6941c12 Author: Andrea Corallo Date: Mon Aug 19 17:08:44 2019 +0200 have subr name in limple diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 9026bf7b53..32fc1866c0 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -328,10 +328,9 @@ If the callee function is known to have a return type propagate it." comp-known-ret-types)))) (comp-emit (list 'set (comp-slot) call))) -(defmacro comp-emit-set-call-subr (subr-name sp-delta &optional c-fun-name) - "Emit a call for SUBR-NAME using C-FUN-NAME. -SP-DELTA is the stack adjustment. -If C-FUN-NAME is nil it will be guessed from SUBR-NAME." +(defmacro comp-emit-set-call-subr (subr-name sp-delta) + "Emit a call for SUBR-NAME. +SP-DELTA is the stack adjustment." (let ((subr (symbol-function subr-name)) (subr-str (symbol-name subr-name)) (nargs (1+ (- sp-delta)))) @@ -340,25 +339,19 @@ If C-FUN-NAME is nil it will be guessed from SUBR-NAME." (let* ((arity (subr-arity subr)) (minarg (car arity)) (maxarg (cdr arity))) - (unless c-fun-name - (setq c-fun-name - (intern (concat "F" - (replace-regexp-in-string - "-" "_" - subr-str))))) (cl-assert (not (eq maxarg 'unevalled)) nil "%s contains unevalled arg" subr-name) (if (eq maxarg 'many) ;; callref case. - `(comp-emit-set-call (list 'callref ',c-fun-name ,nargs (comp-sp))) + `(comp-emit-set-call (list 'callref ',subr-name ,nargs (comp-sp))) ;; Normal call. (cl-assert (and (>= maxarg nargs) (<= minarg nargs)) (nargs maxarg minarg) "Incoherent stack adjustment %d, maxarg %d minarg %d") - `(let* ((c-fun-name ',c-fun-name) + `(let* ((subr-name ',subr-name) (slots (cl-loop for i from 0 below ,maxarg collect (comp-slot-n (+ i (comp-sp)))))) - (comp-emit-set-call `(call ,c-fun-name ,@slots))))))) + (comp-emit-set-call `(call ,subr-name ,@slots))))))) (defun comp-copy-slot (src-n &optional dst-n) "Set slot number DST-N to slot number SRC-N as source. @@ -549,8 +542,7 @@ the annotation emission." ((pred symbolp) (list `(comp-emit-set-call-subr ,(car body) - ,sp-delta - ,(cadr body)))) + ,sp-delta))) (_ body)))) `(pcase op ,@(cl-loop for (op . body) in cases commit 79d4b6915c0dc3e27ca18353bf53ceb31a14ded2 Author: Andrea Corallo Date: Sun Aug 18 23:09:20 2019 +0200 make use of data relocations diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 11803a3ea5..9026bf7b53 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -83,7 +83,7 @@ :documentation "Alist lisp-func-name -> c-func-name. This is build before entering into `comp--compile-ctxt-to-file name'.") (funcs-h (make-hash-table) :type hash-table - :documentation "lisp-func-name -> c-func-name. + :documentation "lisp-func-name -> comp-func. This is to build the prev field.") (data-relocs () :type string :documentation "Final data relocations. @@ -381,7 +381,7 @@ If DST-N is specified use it otherwise assume it to be the current slot." (let ((rel-idx (comp-add-const-to-relocs val))) (setf (comp-slot) (make-comp-mvar :slot (comp-sp) :constant val)) - (comp-emit `(setimm ,(comp-slot) ,rel-idx . ,val)))) + (comp-emit `(setimm ,(comp-slot) ,rel-idx ,val)))) (defun comp-mark-block-closed () "Mark current basic block as closed." @@ -835,23 +835,24 @@ the annotation emission." (setf (comp-ctxt-funcs comp-ctxt) (prin1-to-string (cl-loop with h = (comp-ctxt-funcs-h comp-ctxt) for f being each hash-value of h - collect f))) + for args = (comp-func-args f) + for doc = (aref (comp-func-byte-func f) 4) + collect (vector (comp-func-symbol-name f) + (comp-func-c-func-name f) + (cons (comp-args-base-min args) + (if (comp-args-p args) + (comp-args-max args) + 'many)) + doc)))) (comp--compile-ctxt-to-file name)) (defun comp-add-func-to-ctxt (func) "Add FUNC to the current compiler contex." - (let ((args (comp-func-args func)) - (doc (aref (comp-func-byte-func func) 4))) - (puthash (comp-func-symbol-name func) - (vector (comp-func-symbol-name func) - (comp-func-c-func-name func) - (cons (comp-args-base-min args) - (if (comp-args-p args) - (comp-args-max args) - 'many)) - doc) - (comp-ctxt-funcs-h comp-ctxt))) - (comp--add-func-to-ctxt func)) + (puthash (comp-func-symbol-name func) + func + (comp-ctxt-funcs-h comp-ctxt)) + ;; (comp--add-func-to-ctxt func) + ) ;;; Entry points. diff --git a/src/comp.c b/src/comp.c index 9ccf73ef4b..acf02e7c7c 100644 --- a/src/comp.c +++ b/src/comp.c @@ -149,6 +149,7 @@ typedef struct { Lisp_Object func_blocks; /* blk_name -> gcc_block. */ Lisp_Object func_hash; /* f_name -> gcc_func. */ Lisp_Object emitter_dispatcher; + gcc_jit_rvalue *data_relocs; } comp_t; static comp_t comp; @@ -1349,13 +1350,22 @@ emit_limple_insn (Lisp_Object insn) } else if (EQ (op, Qsetimm)) { - /* EX: (=imm #s(comp-mvar 9 1 t 3 nil) 3). */ - Lisp_Object arg1 = SECOND (args); + /* EX: (=imm #s(comp-mvar 9 1 t 3 nil) 3 a). */ EMACS_UINT slot_n = XFIXNUM (FUNCALL1 (comp-mvar-slot, arg0)); + gcc_jit_rvalue *reloc_n = + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.int_type, + XFIXNUM (SECOND (args))); + emit_comment (SSDATA (Fprin1_to_string (THIRD (args), Qnil))); gcc_jit_block_add_assignment (comp.block, NULL, comp.frame[slot_n], - emit_lisp_obj_from_ptr (arg1)); + gcc_jit_lvalue_as_rvalue ( + gcc_jit_context_new_array_access ( + comp.ctxt, + NULL, + comp.data_relocs, + reloc_n))); } else if (EQ (op, Qcomment)) { @@ -1509,15 +1519,17 @@ emit_ctxt_code (void) XFIXNUM (FUNCALL1 (hash-table-count, FUNCALL1 (comp-ctxt-data-relocs-idx, Vcomp_ctxt))); - gcc_jit_context_new_global ( - comp.ctxt, - NULL, - GCC_JIT_GLOBAL_EXPORTED, - gcc_jit_context_new_array_type (comp.ctxt, + comp.data_relocs + = gcc_jit_lvalue_as_rvalue( + gcc_jit_context_new_global ( + comp.ctxt, + NULL, + GCC_JIT_GLOBAL_EXPORTED, + gcc_jit_context_new_array_type (comp.ctxt, NULL, comp.lisp_obj_type, d_reloc_len), - "data_relocs"); + "data_relocs")); emit_litteral_string_func ("text_data_relocs", d_reloc); @@ -2372,6 +2384,93 @@ define_bool_to_lisp_obj (void) } +static void +compile_function (Lisp_Object func) +{ + char *c_name = (char *) SDATA (FUNCALL1 (comp-func-c-func-name, func)); + Lisp_Object args = FUNCALL1 (comp-func-args, func); + EMACS_INT frame_size = XFIXNUM (FUNCALL1 (comp-func-frame-size, func)); + bool ncall = (FUNCALL1 (comp-nargs-p, args)); + + if (!ncall) + { + EMACS_INT max_args = XFIXNUM (FUNCALL1 (comp-args-max, args)); + comp.func = + emit_func_declare (c_name, comp.lisp_obj_type, max_args, + NULL, GCC_JIT_FUNCTION_EXPORTED, false); + } + else + { + gcc_jit_param *param[] = + { gcc_jit_context_new_param (comp.ctxt, + NULL, + comp.ptrdiff_type, + "nargs"), + gcc_jit_context_new_param (comp.ctxt, + NULL, + comp.lisp_obj_ptr_type, + "args") }; + comp.func = + gcc_jit_context_new_function (comp.ctxt, + NULL, + GCC_JIT_FUNCTION_EXPORTED, + comp.lisp_obj_type, + c_name, 2, param, 0); + } + + gcc_jit_lvalue *frame_array = + gcc_jit_function_new_local ( + comp.func, + NULL, + gcc_jit_context_new_array_type (comp.ctxt, + NULL, + comp.lisp_obj_type, + frame_size), + "local"); + + gcc_jit_lvalue *frame[frame_size]; + for (int i = 0; i < frame_size; ++i) + frame[i] = + gcc_jit_context_new_array_access ( + comp.ctxt, + NULL, + gcc_jit_lvalue_as_rvalue (frame_array), + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.int_type, + i)); + comp.frame = frame; + + comp.func_blocks = CALLN (Fmake_hash_table); + + /* Pre declare all basic blocks to gcc. + The "entry" block must be declared as first. */ + declare_block (Qentry); + Lisp_Object blocks = FUNCALL1 (comp-func-blocks, func); + Lisp_Object entry_block = Fgethash (Qentry, blocks, Qnil); + struct Lisp_Hash_Table *ht = XHASH_TABLE (blocks); + for (ptrdiff_t i = 0; i < ht->count; i++) + { + Lisp_Object block = HASH_VALUE (ht, i); + if (!EQ (block, entry_block)) + declare_block (HASH_KEY (ht, i)); + } + + for (ptrdiff_t i = 0; i < ht->count; i++) + { + Lisp_Object block_name = HASH_KEY (ht, i); + Lisp_Object block = HASH_VALUE (ht, i); + Lisp_Object insns = FUNCALL1 (comp-block-insns, block); + + comp.block = retrive_block (block_name); + while (CONSP (insns)) + { + Lisp_Object insn = XCAR (insns); + emit_limple_insn (insn); + insns = XCDR (insns); + } + } +} + /**********************************/ /* Entry points exposed to lisp. */ @@ -2574,97 +2673,6 @@ DEFUN ("comp--release-ctxt", Fcomp__release_ctxt, Scomp__release_ctxt, return Qt; } -DEFUN ("comp--add-func-to-ctxt", Fcomp__add_func_to_ctxt, - Scomp__add_func_to_ctxt, 1, 1, 0, - doc: /* Add limple FUNC to the current compilation context. */) - (Lisp_Object func) -{ - char *c_name = (char *) SDATA (FUNCALL1 (comp-func-c-func-name, func)); - Lisp_Object args = FUNCALL1 (comp-func-args, func); - EMACS_INT frame_size = XFIXNUM (FUNCALL1 (comp-func-frame-size, func)); - bool ncall = (FUNCALL1 (comp-nargs-p, args)); - - if (!ncall) - { - EMACS_INT max_args = XFIXNUM (FUNCALL1 (comp-args-max, args)); - comp.func = - emit_func_declare (c_name, comp.lisp_obj_type, max_args, - NULL, GCC_JIT_FUNCTION_EXPORTED, false); - } - else - { - gcc_jit_param *param[] = - { gcc_jit_context_new_param (comp.ctxt, - NULL, - comp.ptrdiff_type, - "nargs"), - gcc_jit_context_new_param (comp.ctxt, - NULL, - comp.lisp_obj_ptr_type, - "args") }; - comp.func = - gcc_jit_context_new_function (comp.ctxt, - NULL, - GCC_JIT_FUNCTION_EXPORTED, - comp.lisp_obj_type, - c_name, 2, param, 0); - } - - gcc_jit_lvalue *frame_array = - gcc_jit_function_new_local ( - comp.func, - NULL, - gcc_jit_context_new_array_type (comp.ctxt, - NULL, - comp.lisp_obj_type, - frame_size), - "local"); - - gcc_jit_lvalue *frame[frame_size]; - for (int i = 0; i < frame_size; ++i) - frame[i] = - gcc_jit_context_new_array_access ( - comp.ctxt, - NULL, - gcc_jit_lvalue_as_rvalue (frame_array), - gcc_jit_context_new_rvalue_from_int (comp.ctxt, - comp.int_type, - i)); - comp.frame = frame; - - comp.func_blocks = CALLN (Fmake_hash_table); - - /* Pre declare all basic blocks to gcc. - The "entry" block must be declared as first. */ - declare_block (Qentry); - Lisp_Object blocks = FUNCALL1 (comp-func-blocks, func); - Lisp_Object entry_block = Fgethash (Qentry, blocks, Qnil); - struct Lisp_Hash_Table *ht = XHASH_TABLE (blocks); - for (ptrdiff_t i = 0; i < ht->count; i++) - { - Lisp_Object block = HASH_VALUE (ht, i); - if (!EQ (block, entry_block)) - declare_block (HASH_KEY (ht, i)); - } - - for (ptrdiff_t i = 0; i < ht->count; i++) - { - Lisp_Object block_name = HASH_KEY (ht, i); - Lisp_Object block = HASH_VALUE (ht, i); - Lisp_Object insns = FUNCALL1 (comp-block-insns, block); - - comp.block = retrive_block (block_name); - while (CONSP (insns)) - { - Lisp_Object insn = XCAR (insns); - emit_limple_insn (insn); - insns = XCDR (insns); - } - } - - return Qt; -} - DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, Scomp__compile_ctxt_to_file, 1, 1, 0, @@ -2687,6 +2695,13 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, emit_ctxt_code (); + /* Compile all functions. Can't be done before because the + relocation vectore has to be already compiled. */ + struct Lisp_Hash_Table *func_h + = XHASH_TABLE (FUNCALL1 (comp-ctxt-funcs-h, Vcomp_ctxt)); + for (ptrdiff_t i = 0; i < func_h->count; i++) + compile_function (HASH_VALUE (func_h, i)); + if (COMP_DEBUG) { AUTO_STRING (dot_c, ".c"); @@ -2967,7 +2982,6 @@ syms_of_comp (void) defsubr (&Scomp__init_ctxt); defsubr (&Scomp__release_ctxt); - defsubr (&Scomp__add_func_to_ctxt); defsubr (&Scomp__compile_ctxt_to_file); defsubr (&Snative_elisp_load); commit 20d42249ce8d7fad1e377621e717b238df3a4b05 Author: Andrea Corallo Date: Sun Aug 18 21:39:09 2019 +0200 emit reloc index diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index a453acc329..11803a3ea5 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -378,10 +378,10 @@ If DST-N is specified use it otherwise assume it to be the current slot." (defun comp-emit-set-const (val) "Set constant VAL to current slot." - (comp-add-const-to-relocs val) - (setf (comp-slot) (make-comp-mvar :slot (comp-sp) - :constant val)) - (comp-emit (list 'setimm (comp-slot) val))) + (let ((rel-idx (comp-add-const-to-relocs val))) + (setf (comp-slot) (make-comp-mvar :slot (comp-sp) + :constant val)) + (comp-emit `(setimm ,(comp-slot) ,rel-idx . ,val)))) (defun comp-mark-block-closed () "Mark current basic block as closed." commit 4d7a51eba2c780d10a0b0dac33936c178c677f50 Author: Andrea Corallo Date: Sun Aug 18 21:13:19 2019 +0200 prevent garbage collection diff --git a/src/comp.c b/src/comp.c index 5233a72aa5..9ccf73ef4b 100644 --- a/src/comp.c +++ b/src/comp.c @@ -2827,15 +2827,22 @@ helper_set_data_relocs (Lisp_Object *d_relocs_vec, char const *relocs) } +/*********************************/ +/* Native elisp load functions. */ +/*********************************/ -/************************************/ -/* Native compiler load functions. */ -/************************************/ +static Lisp_Object Vnative_elisp_refs_hash; typedef char *(*comp_litt_str_func) (void); +static void +prevent_gc (Lisp_Object obj) +{ + Fputhash (obj, Qt, Vnative_elisp_refs_hash); +} + static Lisp_Object -comp_retrive_obj (dynlib_handle_ptr handle, const char *str_name) +retrive_litteral_obj (dynlib_handle_ptr handle, const char *str_name) { comp_litt_str_func f = dynlib_sym (handle, str_name); char *res = f(); @@ -2847,13 +2854,16 @@ load_comp_unit (dynlib_handle_ptr handle) { Lisp_Object *data_relocs = dynlib_sym (handle, "data_relocs"); - Lisp_Object d_vec = comp_retrive_obj (handle, "text_data_relocs"); + Lisp_Object d_vec = retrive_litteral_obj (handle, "text_data_relocs"); EMACS_UINT d_vec_len = XFIXNUM (Flength (d_vec)); for (EMACS_UINT i = 0; i < d_vec_len; i++) - data_relocs[i] = AREF (d_vec, i); + { + data_relocs[i] = AREF (d_vec, i); + prevent_gc (data_relocs[i]); + } - Lisp_Object func_list = comp_retrive_obj (handle, "text_funcs"); + Lisp_Object func_list = retrive_litteral_obj (handle, "text_funcs"); while (func_list) { @@ -2905,6 +2915,12 @@ DEFUN ("native-elisp-load", Fnative_elisp_load, Snative_elisp_load, 1, 1, 0, void syms_of_comp (void) { + staticpro (&Vnative_elisp_refs_hash); + Vnative_elisp_refs_hash + = make_hash_table (hashtest_eq, DEFAULT_HASH_SIZE, + DEFAULT_REHASH_SIZE, DEFAULT_REHASH_THRESHOLD, + Qnil, false); + /* Limple instruction set. */ DEFSYM (Qcomment, "comment"); DEFSYM (Qjump, "jump"); commit 70a7c65742244403422d7c3e4b79a2046c1cefb7 Author: Andrea Corallo Date: Sun Aug 18 21:48:49 2019 +0200 move away from modules diff --git a/src/comp.c b/src/comp.c index 953a1dd9d0..5233a72aa5 100644 --- a/src/comp.c +++ b/src/comp.c @@ -31,6 +31,7 @@ along with GNU Emacs. If not, see . */ #include "bytecode.h" #include "atimer.h" #include "window.h" +#include "dynlib.h" #define DEFAULT_SPEED 2 /* See comp-speed var. */ @@ -2555,11 +2556,6 @@ DEFUN ("comp--init-ctxt", Fcomp__init_ctxt, Scomp__init_ctxt, define_add1_sub1 (); define_negate (); - gcc_jit_context_new_global (comp.ctxt, - NULL, - GCC_JIT_GLOBAL_EXPORTED, - comp.int_type, - "native_compiled_emacs_lisp"); return Qt; } @@ -2699,7 +2695,7 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, gcc_jit_context_dump_to_file (comp.ctxt, filename, 1); } - AUTO_STRING (dot_so, ".so"); /* FIXME use correct var */ + AUTO_STRING (dot_so, NATIVE_ELISP_SUFFIX); const char *filename = (const char *) SDATA (CALLN (Fconcat, ctxtname, dot_so)); @@ -2830,6 +2826,81 @@ helper_set_data_relocs (Lisp_Object *d_relocs_vec, char const *relocs) { } + + +/************************************/ +/* Native compiler load functions. */ +/************************************/ + +typedef char *(*comp_litt_str_func) (void); + +static Lisp_Object +comp_retrive_obj (dynlib_handle_ptr handle, const char *str_name) +{ + comp_litt_str_func f = dynlib_sym (handle, str_name); + char *res = f(); + return Fread (build_string (res)); +} + +static int +load_comp_unit (dynlib_handle_ptr handle) +{ + Lisp_Object *data_relocs = dynlib_sym (handle, "data_relocs"); + + Lisp_Object d_vec = comp_retrive_obj (handle, "text_data_relocs"); + EMACS_UINT d_vec_len = XFIXNUM (Flength (d_vec)); + + for (EMACS_UINT i = 0; i < d_vec_len; i++) + data_relocs[i] = AREF (d_vec, i); + + Lisp_Object func_list = comp_retrive_obj (handle, "text_funcs"); + + while (func_list) + { + Lisp_Object el = XCAR (func_list); + Lisp_Object Qsym = AREF (el, 0); + char *c_func_name = SSDATA (AREF (el, 1)); + Lisp_Object args = AREF (el, 2); + ptrdiff_t minargs = XFIXNUM (XCAR (args)); + ptrdiff_t maxargs = FIXNUMP (XCDR (args)) ? XFIXNUM (XCDR (args)) : MANY; + /* char *doc = SSDATA (AREF (el, 3)); */ + void *func = dynlib_sym (handle, c_func_name); + eassert (func); + + union Aligned_Lisp_Subr *x = xmalloc (sizeof (union Aligned_Lisp_Subr)); + x->s.header.size = PVEC_SUBR << PSEUDOVECTOR_AREA_BITS; + x->s.function.a0 = func; + x->s.min_args = minargs; + x->s.max_args = maxargs; + x->s.symbol_name = SSDATA (Fsymbol_name (Qsym)); + defsubr(x); + + func_list = XCDR (func_list); + } + + return 0; +} + +/* Load related routines. */ +DEFUN ("native-elisp-load", Fnative_elisp_load, Snative_elisp_load, 1, 1, 0, + doc: /* Load native elisp code FILE. */) + (Lisp_Object file) +{ + dynlib_handle_ptr handle; + + CHECK_STRING (file); + handle = dynlib_open (SSDATA (file)); + if (!handle) + xsignal2 (Qcomp_unit_open_failed, file, build_string (dynlib_error ())); + + int r = load_comp_unit (handle); + + if (r != 0) + xsignal2 (Qcomp_unit_init_failed, file, INT_TO_INTEGER (r)); + + return Qt; +} + void syms_of_comp (void) @@ -2874,11 +2945,15 @@ syms_of_comp (void) DEFSYM (Qnegate, "negate"); DEFSYM (QFnumberp, "Fnumberp"); DEFSYM (QFintegerp, "Fintegerp"); + /* Returned values. */ + DEFSYM (Qcomp_unit_open_failed, "comp-unit-open-failed"); + DEFSYM (Qcomp_unit_init_failed, "comp-unit-init-failed"); defsubr (&Scomp__init_ctxt); defsubr (&Scomp__release_ctxt); defsubr (&Scomp__add_func_to_ctxt); defsubr (&Scomp__compile_ctxt_to_file); + defsubr (&Snative_elisp_load); staticpro (&comp.func_hash); comp.func_hash = Qnil; diff --git a/src/emacs-module.c b/src/emacs-module.c index e14ef89d8f..bbb0e3dadd 100644 --- a/src/emacs-module.c +++ b/src/emacs-module.c @@ -944,64 +944,6 @@ module_signal_or_throw (struct emacs_env_private *env) } } - -/* - Native compiler load functions. - FIXME: Move away from here. -*/ - -typedef char *(*comp_litt_str_func) (void); - -static Lisp_Object -comp_retrive_obj (dynlib_handle_ptr handle, const char *str_name) -{ - comp_litt_str_func f = dynlib_sym (handle, str_name); - char *res = f(); - return Fread (build_string (res)); -} - -static int -comp_load_unit (dynlib_handle_ptr handle, emacs_env *env) -{ - Lisp_Object *data_relocs = dynlib_sym (handle, "data_relocs"); - - Lisp_Object d_vec = comp_retrive_obj (handle, "text_data_relocs"); - EMACS_UINT d_vec_len = XFIXNUM (Flength (d_vec)); - - for (EMACS_UINT i = 0; i < d_vec_len; i++) - data_relocs[i] = AREF (d_vec, i); - - Lisp_Object func_list = comp_retrive_obj (handle, "text_funcs"); - - while (func_list) - { - Lisp_Object el = XCAR (func_list); - Lisp_Object Qsym = AREF (el, 0); - char *c_func_name = SSDATA (AREF (el, 1)); - Lisp_Object args = AREF (el, 2); - ptrdiff_t minargs = XFIXNUM (XCAR (args)); - ptrdiff_t maxargs = FIXNUMP (XCDR (args)) ? XFIXNUM (XCDR (args)) : MANY; - /* char *doc = SSDATA (AREF (el, 3)); */ - void *func = dynlib_sym (handle, c_func_name); - eassert (func); - /* Ffset (Qsym, */ - /* value_to_lisp (module_make_function (env, minargs, maxargs, func, */ - /* doc, NULL))); */ - - union Aligned_Lisp_Subr *x = xmalloc (sizeof (union Aligned_Lisp_Subr)); - x->s.header.size = PVEC_SUBR << PSEUDOVECTOR_AREA_BITS; - x->s.function.a0 = func; - x->s.min_args = minargs; - x->s.max_args = maxargs; - x->s.symbol_name = SSDATA (Fsymbol_name (Qsym)); - defsubr(x); - - func_list = XCDR (func_list); - } - - return 0; -} - /* Live runtime and environment objects, for assertions. */ static Lisp_Object Vmodule_runtimes; static Lisp_Object Vmodule_environments; @@ -1012,7 +954,7 @@ DEFUN ("module-load", Fmodule_load, Smodule_load, 1, 1, 0, { dynlib_handle_ptr handle; emacs_init_function module_init; - void *gpl_sym, *native_comp; + void *gpl_sym; CHECK_STRING (file); handle = dynlib_open (SSDATA (file)); @@ -1020,17 +962,13 @@ DEFUN ("module-load", Fmodule_load, Smodule_load, 1, 1, 0, xsignal2 (Qmodule_open_failed, file, build_string (dynlib_error ())); gpl_sym = dynlib_sym (handle, "plugin_is_GPL_compatible"); - native_comp = dynlib_sym (handle, "native_compiled_emacs_lisp"); - if (!gpl_sym && !native_comp) + if (!gpl_sym) xsignal1 (Qmodule_not_gpl_compatible, file); - if (!native_comp) - { - module_init = - (emacs_init_function) dynlib_func (handle, "emacs_module_init"); - if (!module_init) - xsignal1 (Qmissing_module_init_function, file); - } + module_init = (emacs_init_function) dynlib_func (handle, "emacs_module_init"); + if (!module_init) + xsignal1 (Qmissing_module_init_function, file); + struct emacs_runtime rt_pub; struct emacs_runtime_private rt_priv; emacs_env env_pub; @@ -1051,7 +989,7 @@ DEFUN ("module-load", Fmodule_load, Smodule_load, 1, 1, 0, ptrdiff_t count = SPECPDL_INDEX (); record_unwind_protect_ptr (finalize_runtime_unwind, rt); - int r = native_comp ? comp_load_unit (handle, &env_pub) : module_init (rt); + int r = module_init (rt); /* Process the quit flag first, so that quitting doesn't get overridden by other non-local exits. */ diff --git a/src/lread.c b/src/lread.c index ca7b29f690..1a5074cb70 100644 --- a/src/lread.c +++ b/src/lread.c @@ -1281,6 +1281,11 @@ Return t if the file exists and loads successfully. */) bool is_module = false; #endif +#ifdef HAVE_LIBGCCJIT + bool is_native_elisp = suffix_p (found, NATIVE_ELISP_SUFFIX); +#else + bool is_native_elisp = false; +#endif /* Check if we're stuck in a recursive load cycle. 2000-09-21: It's not possible to just check for the file loaded @@ -1379,7 +1384,7 @@ Return t if the file exists and loads successfully. */) } /* !load_prefer_newer */ } } - else if (!is_module) + else if (!is_module && !is_native_elisp) { /* We are loading a source file (*.el). */ if (!NILP (Vload_source_file_function)) @@ -1406,7 +1411,7 @@ Return t if the file exists and loads successfully. */) stream = NULL; errno = EINVAL; } - else if (!is_module) + else if (!is_module && !is_native_elisp) { #ifdef WINDOWSNT emacs_close (fd); @@ -1422,7 +1427,7 @@ Return t if the file exists and loads successfully. */) might be accessed by the unbind_to call below. */ struct infile input; - if (is_module) + if (is_module || is_native_elisp) { /* `module-load' uses the file name, so we can close the stream now. */ @@ -1452,6 +1457,8 @@ Return t if the file exists and loads successfully. */) file, 1); else if (is_module) message_with_string ("Loading %s (module)...", file, 1); + else if (is_native_elisp) + message_with_string ("Loading %s (native compiled elisp)...", file, 1); else if (!compiled) message_with_string ("Loading %s (source)...", file, 1); else if (newer) @@ -1475,6 +1482,18 @@ Return t if the file exists and loads successfully. */) #else /* This cannot happen. */ emacs_abort (); +#endif + } + else if (is_native_elisp) + { +#ifdef HAVE_LIBGCCJIT + specbind (Qcurrent_load_list, Qnil); + LOADHIST_ATTACH (found); + Fnative_elisp_load (found); + build_load_history (found, true); +#else + /* This cannot happen. */ + emacs_abort (); #endif } else @@ -4866,21 +4885,19 @@ This list includes suffixes for both compiled and source Emacs Lisp files. This list should not include the empty string. `load' and related functions try to append these suffixes, in order, to the specified file name if a suffix is allowed or required. */); + Vload_suffixes = list2 (build_pure_c_string (".elc"), + build_pure_c_string (".el")); #ifdef HAVE_MODULES + Vload_suffixes = Fcons (build_pure_c_string (MODULES_SUFFIX), Vload_suffixes); #ifdef MODULES_SECONDARY_SUFFIX - Vload_suffixes = list4 (build_pure_c_string (".elc"), - build_pure_c_string (".el"), - build_pure_c_string (MODULES_SUFFIX), - build_pure_c_string (MODULES_SECONDARY_SUFFIX)); -#else - Vload_suffixes = list3 (build_pure_c_string (".elc"), - build_pure_c_string (".el"), - build_pure_c_string (MODULES_SUFFIX)); + Vload_suffixes = + Fcons (build_pure_c_string (MODULES_SECONDARY_SUFFIX), Vload_suffixes); #endif -#else - Vload_suffixes = list2 (build_pure_c_string (".elc"), - build_pure_c_string (".el")); #endif +#ifdef HAVE_LIBGCCJIT + Vload_suffixes = Fcons (build_pure_c_string (NATIVE_ELISP_SUFFIX), Vload_suffixes); +#endif + DEFVAR_LISP ("module-file-suffix", Vmodule_file_suffix, doc: /* Suffix of loadable module file, or nil if modules are not supported. */); #ifdef HAVE_MODULES commit c8a0b81f8ffe093910dd3ad2852dd47a15587d9e Author: Andrea Corallo Date: Sun Aug 18 18:43:33 2019 +0200 basic reload almost working diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 486a7068be..a453acc329 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -253,7 +253,7 @@ BODY is evaluate only if `comp-debug' is non nil." (let ((lambda-list (aref (comp-func-byte-func func) 0))) (if (fixnump lambda-list) (setf (comp-func-args func) - (comp-decrypt-lambda-list (aref (comp-func-byte-func func) 0))) + (comp-decrypt-lambda-list lambda-list)) (error "Can't native compile a non lexical scoped function"))) (setf (comp-func-lap func) byte-compile-lap-output) (setf (comp-func-frame-size func) (aref (comp-func-byte-func func) 3)) @@ -831,19 +831,26 @@ the annotation emission." (cl-assert (= (length (comp-ctxt-data-relocs-l comp-ctxt)) (hash-table-count (comp-ctxt-data-relocs-idx comp-ctxt)))) (setf (comp-ctxt-data-relocs comp-ctxt) - (prin1-to-string (vconcat (reverse (comp-ctxt-data-relocs-l comp-ctxt))))) + (prin1-to-string (vconcat (reverse (comp-ctxt-data-relocs-l comp-ctxt))))) (setf (comp-ctxt-funcs comp-ctxt) - (cl-loop with h = (comp-ctxt-funcs-h comp-ctxt) - for f being each hash-keys of h - using (hash-value c-f) - collect (cons (symbol-name f) c-f))) + (prin1-to-string (cl-loop with h = (comp-ctxt-funcs-h comp-ctxt) + for f being each hash-value of h + collect f))) (comp--compile-ctxt-to-file name)) (defun comp-add-func-to-ctxt (func) "Add FUNC to the current compiler contex." - (puthash (comp-func-symbol-name func) - (comp-func-c-func-name func) - (comp-ctxt-funcs-h comp-ctxt)) + (let ((args (comp-func-args func)) + (doc (aref (comp-func-byte-func func) 4))) + (puthash (comp-func-symbol-name func) + (vector (comp-func-symbol-name func) + (comp-func-c-func-name func) + (cons (comp-args-base-min args) + (if (comp-args-p args) + (comp-args-max args) + 'many)) + doc) + (comp-ctxt-funcs-h comp-ctxt))) (comp--add-func-to-ctxt func)) diff --git a/src/comp.c b/src/comp.c index 65bca050b0..953a1dd9d0 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1473,6 +1473,30 @@ emit_integerp (Lisp_Object insn) &res); } +/* + Is not possibile to initilize static data in libgccjit therfore will create + the following: + + char *str_name (void) + { + return "payload here"; + } +*/ + +static void +emit_litteral_string_func (const char *str_name, const char *str) +{ + gcc_jit_function *f = + gcc_jit_context_new_function (comp.ctxt, NULL, + GCC_JIT_FUNCTION_EXPORTED, + comp.char_ptr_type, + str_name, + 0, NULL, 0); + DECL_BLOCK (block, f); + gcc_jit_rvalue *res = gcc_jit_context_new_string_literal (comp.ctxt, str); + gcc_jit_block_end_with_return (block, NULL, res); +} + /* This emit the code needed by every compilation unit to be loaded. */ @@ -1493,24 +1517,11 @@ emit_ctxt_code (void) comp.lisp_obj_type, d_reloc_len), "data_relocs"); - /* - Is not possibile to initilize static data in libgccjit therfore will create - the following: - char *text_data_relocs (void) - { - return "[a b c... etc]"; - } - */ - gcc_jit_function *f = - gcc_jit_context_new_function (comp.ctxt, NULL, - GCC_JIT_FUNCTION_EXPORTED, - comp.char_ptr_type, - "text_data_relocs", - 0, NULL, 0); - DECL_BLOCK (block, f); - gcc_jit_rvalue *res = gcc_jit_context_new_string_literal (comp.ctxt, d_reloc); - gcc_jit_block_end_with_return (block, NULL, res); + emit_litteral_string_func ("text_data_relocs", d_reloc); + + const char *func_list = SSDATA (FUNCALL1 (comp-ctxt-funcs, Vcomp_ctxt)); + emit_litteral_string_func ("text_funcs", func_list); } @@ -2868,7 +2879,6 @@ syms_of_comp (void) defsubr (&Scomp__release_ctxt); defsubr (&Scomp__add_func_to_ctxt); defsubr (&Scomp__compile_ctxt_to_file); - defsubr (&Scomp_compile_and_load_ctxt); staticpro (&comp.func_hash); comp.func_hash = Qnil; diff --git a/src/emacs-module.c b/src/emacs-module.c index 7b9a5d843d..e14ef89d8f 100644 --- a/src/emacs-module.c +++ b/src/emacs-module.c @@ -944,21 +944,61 @@ module_signal_or_throw (struct emacs_env_private *env) } } -typedef char *(*f_comp_data_relocs) (void); + +/* + Native compiler load functions. + FIXME: Move away from here. +*/ + +typedef char *(*comp_litt_str_func) (void); + +static Lisp_Object +comp_retrive_obj (dynlib_handle_ptr handle, const char *str_name) +{ + comp_litt_str_func f = dynlib_sym (handle, str_name); + char *res = f(); + return Fread (build_string (res)); +} static int -comp_load_unit (dynlib_handle_ptr handle, struct emacs_runtime *rt) +comp_load_unit (dynlib_handle_ptr handle, emacs_env *env) { Lisp_Object *data_relocs = dynlib_sym (handle, "data_relocs"); - f_comp_data_relocs f = dynlib_sym (handle, "text_data_relocs"); - char *text_data_relocs = f(); - Lisp_Object d_vec = Fread (build_string (text_data_relocs)); + Lisp_Object d_vec = comp_retrive_obj (handle, "text_data_relocs"); EMACS_UINT d_vec_len = XFIXNUM (Flength (d_vec)); for (EMACS_UINT i = 0; i < d_vec_len; i++) data_relocs[i] = AREF (d_vec, i); + Lisp_Object func_list = comp_retrive_obj (handle, "text_funcs"); + + while (func_list) + { + Lisp_Object el = XCAR (func_list); + Lisp_Object Qsym = AREF (el, 0); + char *c_func_name = SSDATA (AREF (el, 1)); + Lisp_Object args = AREF (el, 2); + ptrdiff_t minargs = XFIXNUM (XCAR (args)); + ptrdiff_t maxargs = FIXNUMP (XCDR (args)) ? XFIXNUM (XCDR (args)) : MANY; + /* char *doc = SSDATA (AREF (el, 3)); */ + void *func = dynlib_sym (handle, c_func_name); + eassert (func); + /* Ffset (Qsym, */ + /* value_to_lisp (module_make_function (env, minargs, maxargs, func, */ + /* doc, NULL))); */ + + union Aligned_Lisp_Subr *x = xmalloc (sizeof (union Aligned_Lisp_Subr)); + x->s.header.size = PVEC_SUBR << PSEUDOVECTOR_AREA_BITS; + x->s.function.a0 = func; + x->s.min_args = minargs; + x->s.max_args = maxargs; + x->s.symbol_name = SSDATA (Fsymbol_name (Qsym)); + defsubr(x); + + func_list = XCDR (func_list); + } + return 0; } @@ -1011,7 +1051,7 @@ DEFUN ("module-load", Fmodule_load, Smodule_load, 1, 1, 0, ptrdiff_t count = SPECPDL_INDEX (); record_unwind_protect_ptr (finalize_runtime_unwind, rt); - int r = native_comp ? comp_load_unit (handle, rt) : module_init (rt); + int r = native_comp ? comp_load_unit (handle, &env_pub) : module_init (rt); /* Process the quit flag first, so that quitting doesn't get overridden by other non-local exits. */ commit 6f6362207f7d39b5fb10b2968d238e37848a5a9d Author: Andrea Corallo Date: Sun Aug 18 17:17:56 2019 +0200 add funcs into comp-ctxt diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index fe92252405..486a7068be 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -77,8 +77,17 @@ "Hash table lap-op -> stack adjustment.")) (cl-defstruct comp-ctxt + "This structure is to serve al relocation creation for the current compiler + context." + (funcs () :type list + :documentation "Alist lisp-func-name -> c-func-name. +This is build before entering into `comp--compile-ctxt-to-file name'.") + (funcs-h (make-hash-table) :type hash-table + :documentation "lisp-func-name -> c-func-name. +This is to build the prev field.") (data-relocs () :type string - :documentation "Final data relocations.") + :documentation "Final data relocations. +This is build before entering into `comp--compile-ctxt-to-file name'.") (data-relocs-l () :type list :documentation "Constant objects used by functions.") (data-relocs-idx (make-hash-table :test #'equal) :type hash-table @@ -171,14 +180,6 @@ The corresponding index into it is returned." (push obj (comp-ctxt-data-relocs-l comp-ctxt)) (puthash obj (hash-table-count data-relocs-idx) data-relocs-idx)))) -(defun comp-compile-ctxt-to-file (name) - "Compile as native code the current context naming it NAME." - (cl-assert (= (length (comp-ctxt-data-relocs-l comp-ctxt)) - (hash-table-count (comp-ctxt-data-relocs-idx comp-ctxt)))) - (setf (comp-ctxt-data-relocs comp-ctxt) - (prin1-to-string (vconcat (reverse (comp-ctxt-data-relocs-l comp-ctxt))))) - (comp--compile-ctxt-to-file name)) - (defmacro comp-within-log-buff (&rest body) "Execute BODY while at the end the log-buffer. BODY is evaluate only if `comp-debug' is non nil." @@ -822,6 +823,29 @@ the annotation emission." (comp-log-func func) func)) + +;;; C function wrappers + +(defun comp-compile-ctxt-to-file (name) + "Compile as native code the current context naming it NAME." + (cl-assert (= (length (comp-ctxt-data-relocs-l comp-ctxt)) + (hash-table-count (comp-ctxt-data-relocs-idx comp-ctxt)))) + (setf (comp-ctxt-data-relocs comp-ctxt) + (prin1-to-string (vconcat (reverse (comp-ctxt-data-relocs-l comp-ctxt))))) + (setf (comp-ctxt-funcs comp-ctxt) + (cl-loop with h = (comp-ctxt-funcs-h comp-ctxt) + for f being each hash-keys of h + using (hash-value c-f) + collect (cons (symbol-name f) c-f))) + (comp--compile-ctxt-to-file name)) + +(defun comp-add-func-to-ctxt (func) + "Add FUNC to the current compiler contex." + (puthash (comp-func-symbol-name func) + (comp-func-c-func-name func) + (comp-ctxt-funcs-h comp-ctxt)) + (comp--add-func-to-ctxt func)) + ;;; Entry points. @@ -841,7 +865,7 @@ the annotation emission." comp-passes) ;; Once we have the final LIMPLE we jump into C. (comp--init-ctxt) - (comp--add-func-to-ctxt func) + (comp-add-func-to-ctxt func) (comp-compile-ctxt-to-file (symbol-name func-symbol-name)) ;; (comp-compile-and-load-ctxt) (comp--release-ctxt))) commit eb6ac423aa21a50d86056fdda4b2bd58278dbef4 Author: Andrea Corallo Date: Sun Aug 18 17:10:46 2019 +0200 remove function list form the C compiler ctxt diff --git a/src/comp.c b/src/comp.c index babedf258a..65bca050b0 100644 --- a/src/comp.c +++ b/src/comp.c @@ -63,7 +63,7 @@ along with GNU Emacs. If not, see . */ gcc_jit_block *(name) = \ gcc_jit_function_new_block ((func), STR(name)) -/* The compiler context */ +/* C side of the compiler context. */ typedef struct { gcc_jit_context *ctxt; @@ -147,7 +147,6 @@ typedef struct { gcc_jit_function *check_impure; Lisp_Object func_blocks; /* blk_name -> gcc_block. */ Lisp_Object func_hash; /* f_name -> gcc_func. */ - Lisp_Object funcs; /* List of functions defined. */ Lisp_Object emitter_dispatcher; } comp_t; @@ -2405,7 +2404,6 @@ DEFUN ("comp--init-ctxt", Fcomp__init_ctxt, Scomp__init_ctxt, } comp.ctxt = gcc_jit_context_acquire(); - comp.funcs = Qnil; if (COMP_DEBUG) { @@ -2657,8 +2655,6 @@ DEFUN ("comp--add-func-to-ctxt", Fcomp__add_func_to_ctxt, } } - comp.funcs = Fcons (func, comp.funcs); - return Qt; } @@ -2705,61 +2701,61 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, return Qt; } -DEFUN ("comp-compile-and-load-ctxt", Fcomp_compile_and_load_ctxt, - Scomp_compile_and_load_ctxt, - 0, 1, 0, - doc: /* Compile as native code the current context and load its - functions. */) - (Lisp_Object disassemble) -{ - gcc_jit_context_set_int_option (comp.ctxt, - GCC_JIT_INT_OPTION_OPTIMIZATION_LEVEL, - comp_speed); - /* Gcc doesn't like being interrupted at all. */ - sigset_t oldset; - sigset_t blocked; - sigemptyset (&blocked); - sigaddset (&blocked, SIGALRM); - sigaddset (&blocked, SIGINT); - sigaddset (&blocked, SIGIO); - pthread_sigmask (SIG_BLOCK, &blocked, &oldset); - - if (COMP_DEBUG) - gcc_jit_context_dump_to_file (comp.ctxt, "gcc-ctxt-dump.c", 1); - gcc_jit_result *gcc_res = gcc_jit_context_compile(comp.ctxt); - - if (!NILP (disassemble)) - gcc_jit_context_compile_to_file (comp.ctxt, - GCC_JIT_OUTPUT_KIND_ASSEMBLER, - "gcc-ctxt-dump.s"); - - while (CONSP (comp.funcs)) - { - union Aligned_Lisp_Subr *x = xmalloc (sizeof (union Aligned_Lisp_Subr)); - Lisp_Object func = XCAR (comp.funcs); - Lisp_Object args = FUNCALL1 (comp-func-args, func); - char *symbol_name = - (char *) SDATA (SYMBOL_NAME (FUNCALL1 (comp-func-symbol-name, func))); - char *c_name = (char *) SDATA (FUNCALL1 (comp-func-c-func-name, func)); - - x->s.header.size = PVEC_SUBR << PSEUDOVECTOR_AREA_BITS; - x->s.function.a0 = gcc_jit_result_get_code(gcc_res, c_name); - eassert (x->s.function.a0); - x->s.min_args = XFIXNUM (FUNCALL1 (comp-args-base-min, args)); - if (FUNCALL1 (comp-args-p, args)) - x->s.max_args = XFIXNUM (FUNCALL1 (comp-args-max, args)); - else - x->s.max_args = MANY; - x->s.symbol_name = symbol_name; - defsubr(x); - - comp.funcs = XCDR (comp.funcs); - } - - pthread_sigmask (SIG_SETMASK, &oldset, 0); - - return Qt; -} +/* DEFUN ("comp-compile-and-load-ctxt", Fcomp_compile_and_load_ctxt, */ +/* Scomp_compile_and_load_ctxt, */ +/* 0, 1, 0, */ +/* doc: /\* Compile as native code the current context and load its */ +/* functions. *\/) */ +/* (Lisp_Object disassemble) */ +/* { */ +/* gcc_jit_context_set_int_option (comp.ctxt, */ +/* GCC_JIT_INT_OPTION_OPTIMIZATION_LEVEL, */ +/* comp_speed); */ +/* /\* Gcc doesn't like being interrupted at all. *\/ */ +/* sigset_t oldset; */ +/* sigset_t blocked; */ +/* sigemptyset (&blocked); */ +/* sigaddset (&blocked, SIGALRM); */ +/* sigaddset (&blocked, SIGINT); */ +/* sigaddset (&blocked, SIGIO); */ +/* pthread_sigmask (SIG_BLOCK, &blocked, &oldset); */ + +/* if (COMP_DEBUG) */ +/* gcc_jit_context_dump_to_file (comp.ctxt, "gcc-ctxt-dump.c", 1); */ +/* gcc_jit_result *gcc_res = gcc_jit_context_compile(comp.ctxt); */ + +/* if (!NILP (disassemble)) */ +/* gcc_jit_context_compile_to_file (comp.ctxt, */ +/* GCC_JIT_OUTPUT_KIND_ASSEMBLER, */ +/* "gcc-ctxt-dump.s"); */ + +/* while (CONSP (comp.funcs)) */ +/* { */ +/* union Aligned_Lisp_Subr *x = xmalloc (sizeof (union Aligned_Lisp_Subr)); */ +/* Lisp_Object func = XCAR (comp.funcs); */ +/* Lisp_Object args = FUNCALL1 (comp-func-args, func); */ +/* char *symbol_name = */ +/* (char *) SDATA (SYMBOL_NAME (FUNCALL1 (comp-func-symbol-name, func))); */ +/* char *c_name = (char *) SDATA (FUNCALL1 (comp-func-c-func-name, func)); */ + +/* x->s.header.size = PVEC_SUBR << PSEUDOVECTOR_AREA_BITS; */ +/* x->s.function.a0 = gcc_jit_result_get_code(gcc_res, c_name); */ +/* eassert (x->s.function.a0); */ +/* x->s.min_args = XFIXNUM (FUNCALL1 (comp-args-base-min, args)); */ +/* if (FUNCALL1 (comp-args-p, args)) */ +/* x->s.max_args = XFIXNUM (FUNCALL1 (comp-args-max, args)); */ +/* else */ +/* x->s.max_args = MANY; */ +/* x->s.symbol_name = symbol_name; */ +/* defsubr(x); */ + +/* comp.funcs = XCDR (comp.funcs); */ +/* } */ + +/* pthread_sigmask (SIG_SETMASK, &oldset, 0); */ + +/* return Qt; */ +/* } */ /******************************************************************************/ commit 6a65498228c80a6cafc514dee7092b64e9bb84c4 Author: Andrea Corallo Date: Sun Aug 18 16:47:43 2019 +0200 fixup data relocs at load time diff --git a/src/emacs-module.c b/src/emacs-module.c index 1ebcf19c2d..7b9a5d843d 100644 --- a/src/emacs-module.c +++ b/src/emacs-module.c @@ -944,6 +944,24 @@ module_signal_or_throw (struct emacs_env_private *env) } } +typedef char *(*f_comp_data_relocs) (void); + +static int +comp_load_unit (dynlib_handle_ptr handle, struct emacs_runtime *rt) +{ + Lisp_Object *data_relocs = dynlib_sym (handle, "data_relocs"); + f_comp_data_relocs f = dynlib_sym (handle, "text_data_relocs"); + char *text_data_relocs = f(); + + Lisp_Object d_vec = Fread (build_string (text_data_relocs)); + EMACS_UINT d_vec_len = XFIXNUM (Flength (d_vec)); + + for (EMACS_UINT i = 0; i < d_vec_len; i++) + data_relocs[i] = AREF (d_vec, i); + + return 0; +} + /* Live runtime and environment objects, for assertions. */ static Lisp_Object Vmodule_runtimes; static Lisp_Object Vmodule_environments; @@ -966,10 +984,13 @@ DEFUN ("module-load", Fmodule_load, Smodule_load, 1, 1, 0, if (!gpl_sym && !native_comp) xsignal1 (Qmodule_not_gpl_compatible, file); - module_init = (emacs_init_function) dynlib_func (handle, "emacs_module_init"); - if (!module_init) - xsignal1 (Qmissing_module_init_function, file); - + if (!native_comp) + { + module_init = + (emacs_init_function) dynlib_func (handle, "emacs_module_init"); + if (!module_init) + xsignal1 (Qmissing_module_init_function, file); + } struct emacs_runtime rt_pub; struct emacs_runtime_private rt_priv; emacs_env env_pub; @@ -990,7 +1011,7 @@ DEFUN ("module-load", Fmodule_load, Smodule_load, 1, 1, 0, ptrdiff_t count = SPECPDL_INDEX (); record_unwind_protect_ptr (finalize_runtime_unwind, rt); - int r = module_init (rt); + int r = native_comp ? comp_load_unit (handle, rt) : module_init (rt); /* Process the quit flag first, so that quitting doesn't get overridden by other non-local exits. */ commit b6540a8ef5b2725812760f5a9a5cdaef591cb5b4 Author: Andrea Corallo Date: Sun Aug 18 15:37:10 2019 +0200 emit relocs as text into c code diff --git a/src/comp.c b/src/comp.c index 41147e46e0..babedf258a 100644 --- a/src/comp.c +++ b/src/comp.c @@ -170,6 +170,8 @@ bool helper_PSEUDOVECTOR_TYPEP_XUNTAG (const union vectorlike_header *a, void helper_emit_save_restriction (void); +void helper_set_data_relocs (Lisp_Object *d_relocs_vec, char const *relocs); + static char * ATTRIBUTE_FORMAT_PRINTF (1, 2) format_string (const char *format, ...) @@ -1472,6 +1474,46 @@ emit_integerp (Lisp_Object insn) &res); } +/* +This emit the code needed by every compilation unit to be loaded. +*/ +static void +emit_ctxt_code (void) +{ + const char *d_reloc = SSDATA (FUNCALL1 (comp-ctxt-data-relocs, Vcomp_ctxt)); + EMACS_UINT d_reloc_len = + XFIXNUM (FUNCALL1 (hash-table-count, + FUNCALL1 (comp-ctxt-data-relocs-idx, Vcomp_ctxt))); + + gcc_jit_context_new_global ( + comp.ctxt, + NULL, + GCC_JIT_GLOBAL_EXPORTED, + gcc_jit_context_new_array_type (comp.ctxt, + NULL, + comp.lisp_obj_type, + d_reloc_len), + "data_relocs"); + /* + Is not possibile to initilize static data in libgccjit therfore will create + the following: + + char *text_data_relocs (void) + { + return "[a b c... etc]"; + } + */ + gcc_jit_function *f = + gcc_jit_context_new_function (comp.ctxt, NULL, + GCC_JIT_FUNCTION_EXPORTED, + comp.char_ptr_type, + "text_data_relocs", + 0, NULL, 0); + DECL_BLOCK (block, f); + gcc_jit_rvalue *res = gcc_jit_context_new_string_literal (comp.ctxt, d_reloc); + gcc_jit_block_end_with_return (block, NULL, res); +} + /****************************************************************/ /* Inline function definition and lisp data structure follows. */ @@ -1591,7 +1633,7 @@ define_lisp_cons (void) } -/* opaque jmp_buf definition. */ +/* Opaque jmp_buf definition. */ static void define_jmp_buf (void) @@ -2640,6 +2682,8 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, sigaddset (&blocked, SIGIO); pthread_sigmask (SIG_BLOCK, &blocked, &oldset); + emit_ctxt_code (); + if (COMP_DEBUG) { AUTO_STRING (dot_c, ".c"); @@ -2648,7 +2692,7 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, gcc_jit_context_dump_to_file (comp.ctxt, filename, 1); } - AUTO_STRING (dot_so, ".so"); + AUTO_STRING (dot_so, ".so"); /* FIXME use correct var */ const char *filename = (const char *) SDATA (CALLN (Fconcat, ctxtname, dot_so)); @@ -2774,6 +2818,11 @@ helper_emit_save_restriction (void) save_restriction_save ()); } +void +helper_set_data_relocs (Lisp_Object *d_relocs_vec, char const *relocs) +{ +} + void syms_of_comp (void) commit 765e57e2d25d34280b25b925dd8ede4cbfd39020 Author: Andrea Corallo Date: Sun Aug 18 15:36:36 2019 +0200 improve relocation collection diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index a55d369570..fe92252405 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -76,6 +76,18 @@ finally return h) "Hash table lap-op -> stack adjustment.")) +(cl-defstruct comp-ctxt + (data-relocs () :type string + :documentation "Final data relocations.") + (data-relocs-l () :type list + :documentation "Constant objects used by functions.") + (data-relocs-idx (make-hash-table :test #'equal) :type hash-table + :documentation "Obj -> position into data-relocs.") + (func-relocs () :type list + :documentation "Native functions imported.") + (func-relocs-idx (make-hash-table :test #'equal) :type hash-table + :documentation "Obj -> position into func-relocs.")) + (cl-defstruct comp-args-base (min nil :type number :documentation "Minimum number of arguments allowed.")) @@ -148,6 +160,25 @@ LIMPLE basic block.") (block-name nil :type symbol :documentation "Current basic block name.")) +(defvar comp-ctxt) ;; FIXME (to be removed) + + +(defun comp-add-const-to-relocs (obj) + "Keep track of OBJ into relocations. +The corresponding index into it is returned." + (let ((data-relocs-idx (comp-ctxt-data-relocs-idx comp-ctxt))) + (unless (gethash obj data-relocs-idx) + (push obj (comp-ctxt-data-relocs-l comp-ctxt)) + (puthash obj (hash-table-count data-relocs-idx) data-relocs-idx)))) + +(defun comp-compile-ctxt-to-file (name) + "Compile as native code the current context naming it NAME." + (cl-assert (= (length (comp-ctxt-data-relocs-l comp-ctxt)) + (hash-table-count (comp-ctxt-data-relocs-idx comp-ctxt)))) + (setf (comp-ctxt-data-relocs comp-ctxt) + (prin1-to-string (vconcat (reverse (comp-ctxt-data-relocs-l comp-ctxt))))) + (comp--compile-ctxt-to-file name)) + (defmacro comp-within-log-buff (&rest body) "Execute BODY while at the end the log-buffer. BODY is evaluate only if `comp-debug' is non nil." @@ -346,6 +377,7 @@ If DST-N is specified use it otherwise assume it to be the current slot." (defun comp-emit-set-const (val) "Set constant VAL to current slot." + (comp-add-const-to-relocs val) (setf (comp-slot) (make-comp-mvar :slot (comp-sp) :constant val)) (comp-emit (list 'setimm (comp-slot) val))) @@ -802,16 +834,17 @@ the annotation emission." (let ((func (make-comp-func :symbol-name func-symbol-name :func f :c-func-name (comp-c-func-name - func-symbol-name)))) + func-symbol-name))) + (comp-ctxt (make-comp-ctxt))) (mapc (lambda (pass) (funcall pass func)) comp-passes) ;; Once we have the final LIMPLE we jump into C. - (comp-init-ctxt) - (comp-add-func-to-ctxt func) + (comp--init-ctxt) + (comp--add-func-to-ctxt func) (comp-compile-ctxt-to-file (symbol-name func-symbol-name)) ;; (comp-compile-and-load-ctxt) - (comp-release-ctxt))) + (comp--release-ctxt))) (error "Trying to native compile something not a function"))) (provide 'comp) commit f5ab0db4b03c497112fdcde3b8b270c3fa14a3c3 Author: Andrea Corallo Date: Sun Aug 18 11:07:54 2019 +0200 rename a bunch o f functions as private diff --git a/src/comp.c b/src/comp.c index 1d53038d47..41147e46e0 100644 --- a/src/comp.c +++ b/src/comp.c @@ -2324,7 +2324,7 @@ define_bool_to_lisp_obj (void) /* Entry points exposed to lisp. */ /**********************************/ -DEFUN ("comp-init-ctxt", Fcomp_init_ctxt, Scomp_init_ctxt, +DEFUN ("comp--init-ctxt", Fcomp__init_ctxt, Scomp__init_ctxt, 0, 0, 0, doc: /* Initialize the native compiler context. Return t on success. */) (void) @@ -2512,7 +2512,7 @@ DEFUN ("comp-init-ctxt", Fcomp_init_ctxt, Scomp_init_ctxt, return Qt; } -DEFUN ("comp-release-ctxt", Fcomp_release_ctxt, Scomp_release_ctxt, +DEFUN ("comp--release-ctxt", Fcomp__release_ctxt, Scomp__release_ctxt, 0, 0, 0, doc: /* Release the native compiler context. */) (void) @@ -2527,8 +2527,8 @@ DEFUN ("comp-release-ctxt", Fcomp_release_ctxt, Scomp_release_ctxt, return Qt; } -DEFUN ("comp-add-func-to-ctxt", Fcomp_add_func_to_ctxt, Scomp_add_func_to_ctxt, - 1, 1, 0, +DEFUN ("comp--add-func-to-ctxt", Fcomp__add_func_to_ctxt, + Scomp__add_func_to_ctxt, 1, 1, 0, doc: /* Add limple FUNC to the current compilation context. */) (Lisp_Object func) { @@ -2620,8 +2620,8 @@ DEFUN ("comp-add-func-to-ctxt", Fcomp_add_func_to_ctxt, Scomp_add_func_to_ctxt, return Qt; } -DEFUN ("comp-compile-ctxt-to-file", Fcomp_compile_ctxt_to_file, - Scomp_compile_ctxt_to_file, +DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, + Scomp__compile_ctxt_to_file, 1, 1, 0, doc: /* Compile as native code the current context to file. */) (Lisp_Object ctxtname) @@ -2780,7 +2780,6 @@ syms_of_comp (void) { /* Limple instruction set. */ DEFSYM (Qcomment, "comment"); - DEFSYM (Qconst_vector, "const-vector"); DEFSYM (Qjump, "jump"); DEFSYM (Qcall, "call"); DEFSYM (Qcallref, "callref"); @@ -2820,10 +2819,10 @@ syms_of_comp (void) DEFSYM (QFnumberp, "Fnumberp"); DEFSYM (QFintegerp, "Fintegerp"); - defsubr (&Scomp_init_ctxt); - defsubr (&Scomp_release_ctxt); - defsubr (&Scomp_add_func_to_ctxt); - defsubr (&Scomp_compile_ctxt_to_file); + defsubr (&Scomp__init_ctxt); + defsubr (&Scomp__release_ctxt); + defsubr (&Scomp__add_func_to_ctxt); + defsubr (&Scomp__compile_ctxt_to_file); defsubr (&Scomp_compile_and_load_ctxt); staticpro (&comp.func_hash); commit 7cd401f63db705acb8ede6624c293843b41e7e20 Author: Andrea Corallo Date: Sun Aug 18 11:07:09 2019 +0200 declare comp-ctxt Vcomp_ctxt diff --git a/src/comp.c b/src/comp.c index b1116aa961..1d53038d47 100644 --- a/src/comp.c +++ b/src/comp.c @@ -2834,6 +2834,11 @@ syms_of_comp (void) DEFVAR_INT ("comp-speed", comp_speed, doc: /* From 0 to 3. */); + DEFVAR_LISP ("comp-ctxt", Vcomp_ctxt, + doc: /* + The compiler context. */); + Vcomp_ctxt = Qnil; + comp_speed = DEFAULT_SPEED; } commit 941937d295dce322e00a1d77b61041e6bda5cfd8 Author: Andrea Corallo Date: Sun Aug 18 11:06:48 2019 +0200 disable const vect per function diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index fdb1b38613..a55d369570 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -773,9 +773,6 @@ the annotation emission." (comp-emit-block 'entry) (comp-emit-annotation (concat "Lisp function: " (symbol-name (comp-func-symbol-name func)))) - (comp-emit `(const-vector ,(concat (comp-func-c-func-name func) "_data_relocs") - ,(prin1-to-string (aref (comp-func-byte-func func) - 2)))) (if (comp-args-p args) (cl-loop for i below (comp-args-max args) do (cl-incf (comp-sp)) diff --git a/src/comp.c b/src/comp.c index 32ece133c5..b1116aa961 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1360,23 +1360,6 @@ emit_limple_insn (Lisp_Object insn) /* Ex: (comment "Function: foo"). */ emit_comment((char *) SDATA (arg0)); } - else if (EQ (op, Qconst_vector)) - { - /* Ex: (const-vector "F666f6f_foo_reloc" - "[a b c 1 2]"). */ - Lisp_Object vec = SECOND (args); - EMACS_INT v_len = XFIXNUM (FUNCALL1 (length, vec)); - - gcc_jit_context_new_global ( - comp.ctxt, - NULL, - GCC_JIT_GLOBAL_INTERNAL, - gcc_jit_context_new_array_type (comp.ctxt, - NULL, - comp.lisp_obj_type, - v_len), - (char *) SDATA (arg0)); - } else if (EQ (op, Qreturn)) { gcc_jit_block_end_with_return (comp.block, commit 52089993aa3231ccdfd0469aeb7c3e7b6b89edad Author: Andrea Corallo Date: Sun Aug 18 10:34:18 2019 +0200 no need to quote types into structs diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 9c31206cc2..fdb1b38613 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -97,7 +97,7 @@ To be used when ncall-conv is nil.")) (sp nil :documentation "When non nil indicates the sp value while entering into it.") - (closed nil :type 'boolean + (closed nil :type boolean :documentation "If the block was already closed.") (insns () :type list :documentation "List of instructions.")) @@ -106,7 +106,7 @@ into it.") "LIMPLE representation of a function." (symbol-name nil :documentation "Function symbol's name.") - (c-func-name nil :type 'string + (c-func-name nil :type string :documentation "The function name in the native world.") (func nil :documentation "Original form.") @@ -114,15 +114,15 @@ into it.") :documentation "Byte compiled version.") (lap () :type list :documentation "Lap assembly representation.") - (args nil :type 'comp-args-base) - (frame-size nil :type 'number) - (blocks (make-hash-table) :type 'hash-table + (args nil :type comp-args-base) + (frame-size nil :type number) + (blocks (make-hash-table) :type hash-table :documentation "Key is the basic block symbol value is a comp-block structure.") - (lap-block (make-hash-table :test #'equal) :type 'hash-table + (lap-block (make-hash-table :test #'equal) :type hash-table :documentation "Key value to convert from LAP label number to LIMPLE basic block.") - (ssa-cnt -1 :type 'number + (ssa-cnt -1 :type number :documentation "Counter to create ssa limple vars.")) (cl-defstruct (comp-mvar (:copier nil) (:constructor make--comp-mvar)) @@ -141,11 +141,11 @@ LIMPLE basic block.") (cl-defstruct (comp-limplify (:copier nil)) "Support structure used during limplification." - (sp 0 :type 'fixnum + (sp 0 :type fixnum :documentation "Current stack pointer while walking LAP.") - (frame nil :type 'vector + (frame nil :type vector :documentation "Meta-stack used to flat LAP.") - (block-name nil :type 'symbol + (block-name nil :type symbol :documentation "Current basic block name.")) (defmacro comp-within-log-buff (&rest body) commit f4603ab67438ec1a31b35918608dc4db410be9c5 Author: Andrea Corallo Date: Fri Aug 16 21:49:56 2019 +0200 render data_relocs vector diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 80b71590ec..9c31206cc2 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -773,6 +773,9 @@ the annotation emission." (comp-emit-block 'entry) (comp-emit-annotation (concat "Lisp function: " (symbol-name (comp-func-symbol-name func)))) + (comp-emit `(const-vector ,(concat (comp-func-c-func-name func) "_data_relocs") + ,(prin1-to-string (aref (comp-func-byte-func func) + 2)))) (if (comp-args-p args) (cl-loop for i below (comp-args-max args) do (cl-incf (comp-sp)) @@ -809,7 +812,8 @@ the annotation emission." ;; Once we have the final LIMPLE we jump into C. (comp-init-ctxt) (comp-add-func-to-ctxt func) - (comp-compile-and-load-ctxt) + (comp-compile-ctxt-to-file (symbol-name func-symbol-name)) + ;; (comp-compile-and-load-ctxt) (comp-release-ctxt))) (error "Trying to native compile something not a function"))) diff --git a/src/comp.c b/src/comp.c index e3343afc7b..32ece133c5 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1360,12 +1360,33 @@ emit_limple_insn (Lisp_Object insn) /* Ex: (comment "Function: foo"). */ emit_comment((char *) SDATA (arg0)); } + else if (EQ (op, Qconst_vector)) + { + /* Ex: (const-vector "F666f6f_foo_reloc" + "[a b c 1 2]"). */ + Lisp_Object vec = SECOND (args); + EMACS_INT v_len = XFIXNUM (FUNCALL1 (length, vec)); + + gcc_jit_context_new_global ( + comp.ctxt, + NULL, + GCC_JIT_GLOBAL_INTERNAL, + gcc_jit_context_new_array_type (comp.ctxt, + NULL, + comp.lisp_obj_type, + v_len), + (char *) SDATA (arg0)); + } else if (EQ (op, Qreturn)) { gcc_jit_block_end_with_return (comp.block, NULL, emit_mvar_val (arg0)); } + else + { + error ("LIMPLE op inconsistent"); + } } @@ -2622,8 +2643,7 @@ DEFUN ("comp-compile-ctxt-to-file", Fcomp_compile_ctxt_to_file, doc: /* Compile as native code the current context to file. */) (Lisp_Object ctxtname) { - if (!STRINGP (ctxtname)) - error ("Argument ctxtname not a string"); + CHECK_STRING (ctxtname); gcc_jit_context_set_int_option (comp.ctxt, GCC_JIT_INT_OPTION_OPTIMIZATION_LEVEL, @@ -2777,6 +2797,7 @@ syms_of_comp (void) { /* Limple instruction set. */ DEFSYM (Qcomment, "comment"); + DEFSYM (Qconst_vector, "const-vector"); DEFSYM (Qjump, "jump"); DEFSYM (Qcall, "call"); DEFSYM (Qcallref, "callref"); commit 311c278c5bb26291fbe6d2e28130c43a08dce096 Author: Andrea Corallo Date: Fri Aug 16 22:09:29 2019 +0200 export native_compiled_emacs_lisp symbol and make it loadable. diff --git a/src/comp.c b/src/comp.c index b150292041..e3343afc7b 100644 --- a/src/comp.c +++ b/src/comp.c @@ -2500,6 +2500,11 @@ DEFUN ("comp-init-ctxt", Fcomp_init_ctxt, Scomp_init_ctxt, define_add1_sub1 (); define_negate (); + gcc_jit_context_new_global (comp.ctxt, + NULL, + GCC_JIT_GLOBAL_EXPORTED, + comp.int_type, + "native_compiled_emacs_lisp"); return Qt; } diff --git a/src/emacs-module.c b/src/emacs-module.c index bbb0e3dadd..1ebcf19c2d 100644 --- a/src/emacs-module.c +++ b/src/emacs-module.c @@ -954,7 +954,7 @@ DEFUN ("module-load", Fmodule_load, Smodule_load, 1, 1, 0, { dynlib_handle_ptr handle; emacs_init_function module_init; - void *gpl_sym; + void *gpl_sym, *native_comp; CHECK_STRING (file); handle = dynlib_open (SSDATA (file)); @@ -962,7 +962,8 @@ DEFUN ("module-load", Fmodule_load, Smodule_load, 1, 1, 0, xsignal2 (Qmodule_open_failed, file, build_string (dynlib_error ())); gpl_sym = dynlib_sym (handle, "plugin_is_GPL_compatible"); - if (!gpl_sym) + native_comp = dynlib_sym (handle, "native_compiled_emacs_lisp"); + if (!gpl_sym && !native_comp) xsignal1 (Qmodule_not_gpl_compatible, file); module_init = (emacs_init_function) dynlib_func (handle, "emacs_module_init"); commit c4d723e865e86a83cf87d4cc42e7dbca799dc4ff Author: Andrea Corallo Date: Fri Aug 16 17:15:35 2019 +0200 add comp-compile-ctxt-to-file diff --git a/src/comp.c b/src/comp.c index 1e1060fd87..b150292041 100644 --- a/src/comp.c +++ b/src/comp.c @@ -224,7 +224,7 @@ type_to_cast_field (gcc_jit_type *type) else if (type == comp.lisp_obj_ptr_type) field = comp.cast_union_as_lisp_obj_ptr; else - error ("unsupported cast\n"); + error ("Unsupported cast"); return field; } @@ -2327,7 +2327,7 @@ DEFUN ("comp-init-ctxt", Fcomp_init_ctxt, Scomp_init_ctxt, { if (comp.ctxt) { - error ("Compiler context already taken."); + error ("Compiler context already taken"); return Qnil; } @@ -2611,6 +2611,48 @@ DEFUN ("comp-add-func-to-ctxt", Fcomp_add_func_to_ctxt, Scomp_add_func_to_ctxt, return Qt; } +DEFUN ("comp-compile-ctxt-to-file", Fcomp_compile_ctxt_to_file, + Scomp_compile_ctxt_to_file, + 1, 1, 0, + doc: /* Compile as native code the current context to file. */) + (Lisp_Object ctxtname) +{ + if (!STRINGP (ctxtname)) + error ("Argument ctxtname not a string"); + + gcc_jit_context_set_int_option (comp.ctxt, + GCC_JIT_INT_OPTION_OPTIMIZATION_LEVEL, + comp_speed); + /* Gcc doesn't like being interrupted at all. */ + sigset_t oldset; + sigset_t blocked; + sigemptyset (&blocked); + sigaddset (&blocked, SIGALRM); + sigaddset (&blocked, SIGINT); + sigaddset (&blocked, SIGIO); + pthread_sigmask (SIG_BLOCK, &blocked, &oldset); + + if (COMP_DEBUG) + { + AUTO_STRING (dot_c, ".c"); + const char *filename = + (const char *) SDATA (CALLN (Fconcat, ctxtname, dot_c)); + gcc_jit_context_dump_to_file (comp.ctxt, filename, 1); + } + + AUTO_STRING (dot_so, ".so"); + const char *filename = + (const char *) SDATA (CALLN (Fconcat, ctxtname, dot_so)); + + gcc_jit_context_compile_to_file (comp.ctxt, + GCC_JIT_OUTPUT_KIND_DYNAMIC_LIBRARY, + filename); + + pthread_sigmask (SIG_SETMASK, &oldset, 0); + + return Qt; +} + DEFUN ("comp-compile-and-load-ctxt", Fcomp_compile_and_load_ctxt, Scomp_compile_and_load_ctxt, 0, 1, 0, @@ -2772,6 +2814,7 @@ syms_of_comp (void) defsubr (&Scomp_init_ctxt); defsubr (&Scomp_release_ctxt); defsubr (&Scomp_add_func_to_ctxt); + defsubr (&Scomp_compile_ctxt_to_file); defsubr (&Scomp_compile_and_load_ctxt); staticpro (&comp.func_hash); commit bdcd8dd9fe4a9926a0dbc46ee1180ef53a91bf17 Author: Andrea Corallo Date: Fri Aug 16 15:48:38 2019 +0200 some other renaming diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 1c2ac4c6e4..80b71590ec 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -76,16 +76,16 @@ finally return h) "Hash table lap-op -> stack adjustment.")) -(cl-defstruct comp-args-gen +(cl-defstruct comp-args-base (min nil :type number :documentation "Minimum number of arguments allowed.")) -(cl-defstruct (comp-args (:include comp-args-gen)) +(cl-defstruct (comp-args (:include comp-args-base)) (max nil :type number :documentation "Maximum number of arguments allowed. To be used when ncall-conv is nil.")) -(cl-defstruct (comp-nargs (:include comp-args-gen)) +(cl-defstruct (comp-nargs (:include comp-args-base)) "Describe args when the functin signature is of kind: (ptrdiff_t nargs, Lisp_Object *args)." (nonrest nil :type number @@ -114,7 +114,7 @@ into it.") :documentation "Byte compiled version.") (lap () :type list :documentation "Lap assembly representation.") - (args nil :type 'comp-args-gen) + (args nil :type 'comp-args-base) (frame-size nil :type 'number) (blocks (make-hash-table) :type 'hash-table :documentation "Key is the basic block symbol value is a comp-block @@ -767,7 +767,7 @@ the annotation emission." :sp -1 :frame (comp-new-frame frame-size))) (args (comp-func-args func)) - (args-min (comp-args-gen-min args)) + (args-min (comp-args-base-min args)) (comp-block ())) ;; Prologue (comp-emit-block 'entry) diff --git a/src/comp.c b/src/comp.c index 95bfb5d561..1e1060fd87 100644 --- a/src/comp.c +++ b/src/comp.c @@ -2651,7 +2651,7 @@ DEFUN ("comp-compile-and-load-ctxt", Fcomp_compile_and_load_ctxt, x->s.header.size = PVEC_SUBR << PSEUDOVECTOR_AREA_BITS; x->s.function.a0 = gcc_jit_result_get_code(gcc_res, c_name); eassert (x->s.function.a0); - x->s.min_args = XFIXNUM (FUNCALL1 (comp-args-gen-min, args)); + x->s.min_args = XFIXNUM (FUNCALL1 (comp-args-base-min, args)); if (FUNCALL1 (comp-args-p, args)) x->s.max_args = XFIXNUM (FUNCALL1 (comp-args-max, args)); else commit 24fe275711aa0964051f3b95c9bc9b4a3e524826 Author: Andrea Corallo Date: Fri Aug 16 10:38:51 2019 +0200 optimize self calls diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index a95cd56eae..1c2ac4c6e4 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -463,6 +463,38 @@ If NEGATED non nil negate the tested condition." for m-test = (make-comp-mvar :constant test) do (comp-emit-cond-jump var m-test 0 target-label nil))) +(defun comp-emit-funcall (narg) + "Avoid Ffuncall trampoline if possibile. +NARG is the number of Ffuncall arguments." + (comp-stack-adjust (- narg)) + (let* ((callee (comp-slot)) + (callee-sym-name (comp-mvar-constant callee)) + (optimize nil) + (callref nil)) + (and (comp-mvar-const-vld callee) + (or (and (>= comp-speed 2) + (eq callee-sym-name (comp-func-symbol-name comp-func)) + (setq optimize t) + (setq callref (comp-nargs-p (comp-func-args comp-func)))) + ;; (and (>= comp-speed 3) + ;; (symbol-function callee-sym-name) + ;; (subrp (symbol-function callee-sym-name)) + ;; (setq optimize t) + ;; (setq callref (eq 'many + ;; (cdr (subr-arity + ;; (symbol-function callee-sym-name))))) + ;; (setf callee-sym-name )) + )) + (if optimize + (if callref + (comp-emit-set-call `(callref ,callee-sym-name + ,narg ,(1+ (comp-sp)))) + (comp-emit-set-call `(call ,callee-sym-name + ,@(cl-loop for i from (1+ (comp-sp)) + repeat narg + collect (comp-slot-n i))))) + (comp-emit-set-call `(callref Ffuncall ,(1+ narg) ,(comp-sp)))))) + (defmacro comp-op-case (&rest cases) "Expand CASES into the corresponding pcase. This is responsible for generating the proper stack adjustment when known and @@ -529,8 +561,7 @@ the annotation emission." ,(make-comp-mvar :constant arg) ,(comp-slot-next)))) (byte-call - (comp-stack-adjust (- arg)) - (comp-emit-set-call `(callref Ffuncall ,(1+ arg) ,(comp-sp)))) + (comp-emit-funcall arg)) (byte-unbind (comp-emit `(call helper_unbind_n ,(make-comp-mvar :constant arg)))) diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index e7b370c932..55797f1352 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -29,6 +29,8 @@ (require 'comp) ;; (require 'cl-lib) +(setq comp-speed 3) + (defun comp-test-apply (func &rest args) (unless (subrp (symbol-function func)) (native-compile func)) commit 281d3a7aadefb673917bc585224c9bf7dae449e6 Author: Andrea Corallo Date: Fri Aug 16 08:51:02 2019 +0200 some renaming diff --git a/src/comp.c b/src/comp.c index e1ffcf94ec..95bfb5d561 100644 --- a/src/comp.c +++ b/src/comp.c @@ -340,7 +340,7 @@ emit_call (const char *f_name, gcc_jit_type *ret_type, unsigned nargs, static gcc_jit_rvalue * emit_call_ref (const char *f_name, unsigned nargs, - gcc_jit_lvalue *base_arg) + gcc_jit_lvalue *base_arg) { gcc_jit_rvalue *args[] = { gcc_jit_context_new_rvalue_from_int(comp.ctxt, @@ -1048,33 +1048,33 @@ emit_simple_limple_call_void_ret (Lisp_Object args) /* Entry point to dispatch emitting (call fun ...). */ static gcc_jit_rvalue * -emit_limple_call (Lisp_Object args) +emit_limple_call (Lisp_Object insn) { - Lisp_Object callee_sym = FIRST (args); + Lisp_Object callee_sym = FIRST (insn); char *callee = (char *) SDATA (SYMBOL_NAME (callee_sym)); Lisp_Object emitter = Fgethash (callee_sym, comp.emitter_dispatcher, Qnil); if (!NILP (emitter)) { gcc_jit_rvalue * (* emitter_ptr) (Lisp_Object) = xmint_pointer (emitter); - return emitter_ptr (args); + return emitter_ptr (insn); } else if (callee[0] == 'F') { - return emit_simple_limple_call_lisp_ret (args); + return emit_simple_limple_call_lisp_ret (insn); } error ("LIMPLE call is inconsistent"); } static gcc_jit_rvalue * -emit_limple_call_ref (Lisp_Object args) +emit_limple_call_ref (Lisp_Object insn) { /* Ex: (callref Fplus 2 0). */ - char *callee = (char *) SDATA (SYMBOL_NAME (FIRST (args))); - EMACS_UINT nargs = XFIXNUM (SECOND (args)); - EMACS_UINT base_ptr = XFIXNUM (THIRD (args)); + char *callee = (char *) SDATA (SYMBOL_NAME (FIRST (insn))); + EMACS_UINT nargs = XFIXNUM (SECOND (insn)); + EMACS_UINT base_ptr = XFIXNUM (THIRD (insn)); return emit_call_ref (callee, nargs, comp.frame[base_ptr]); } commit 291531a7e46edcf52f49e193114e818c111d7af6 Author: Andrea Corallo Date: Thu Aug 15 22:48:48 2019 +0200 code clean-up diff --git a/src/comp.c b/src/comp.c index 6a576cfe11..e1ffcf94ec 100644 --- a/src/comp.c +++ b/src/comp.c @@ -378,23 +378,6 @@ emit_cond_jump (gcc_jit_rvalue *test, } -/* Close current basic block emitting a comparison between two rval. */ - -/* static gcc_jit_rvalue * */ -/* emit_comparison_jump (enum gcc_jit_comparison op, */ -/* gcc_jit_rvalue *a, gcc_jit_rvalue *b, */ -/* gcc_jit_block *then_target, gcc_jit_block *else_target) */ -/* { */ -/* gcc_jit_rvalue *test = gcc_jit_context_new_comparison (comp.ctxt, */ -/* NULL, */ -/* op, */ -/* a, b); */ - -/* emit_cond_jump (test, then_target, else_target); */ - -/* return test; */ -/* } */ - static gcc_jit_rvalue * emit_cast (gcc_jit_type *new_type, gcc_jit_rvalue *obj) { @@ -2755,7 +2738,7 @@ syms_of_comp (void) DEFSYM (Qreturn, "return"); DEFSYM (Qcomp_mvar, "comp-mvar"); DEFSYM (Qcond_jump, "cond-jump"); - /* Used during prologue emission. */ + /* In use for prologue emission. */ DEFSYM (Qset_par_to_local, "set-par-to-local"); DEFSYM (Qset_args_to_local, "set-args-to-local"); DEFSYM (Qset_rest_args_to_local, "set-rest-args-to-local"); commit fd6c673cfa76b30d3910963982e2c28ca208e827 Author: Andrea Corallo Date: Thu Aug 15 22:45:30 2019 +0200 inline setcar setcdr diff --git a/src/comp.c b/src/comp.c index 71dda17399..6a576cfe11 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1443,6 +1443,30 @@ emit_cdr (Lisp_Object insn) 1, &x); } +static gcc_jit_rvalue * +emit_setcar (Lisp_Object insn) +{ + gcc_jit_rvalue *args[] = + { emit_mvar_val (SECOND (insn)), + emit_mvar_val (THIRD (insn)) }; + return gcc_jit_context_new_call (comp.ctxt, + NULL, + comp.setcar, + 2, args); +} + +static gcc_jit_rvalue * +emit_setcdr (Lisp_Object insn) +{ + gcc_jit_rvalue *args[] = + { emit_mvar_val (SECOND (insn)), + emit_mvar_val (THIRD (insn)) }; + return gcc_jit_context_new_call (comp.ctxt, + NULL, + comp.setcdr, + 2, args); +} + static gcc_jit_rvalue * emit_numperp (Lisp_Object insn) { @@ -2344,6 +2368,8 @@ DEFUN ("comp-init-ctxt", Fcomp_init_ctxt, Scomp_init_ctxt, register_emitter (QFconsp, emit_consp); register_emitter (QFcar, emit_car); register_emitter (QFcdr, emit_cdr); + register_emitter (QFsetcar, emit_setcar); + register_emitter (QFsetcdr, emit_setcdr); register_emitter (Qnegate, emit_negate); register_emitter (QFnumberp, emit_numperp); register_emitter (QFintegerp, emit_integerp); @@ -2754,6 +2780,8 @@ syms_of_comp (void) DEFSYM (QFconsp, "Fconsp"); DEFSYM (QFcar, "Fcar"); DEFSYM (QFcdr, "Fcdr"); + DEFSYM (QFsetcar, "Fsetcar"); + DEFSYM (QFsetcdr, "Fsetcdr"); DEFSYM (Qnegate, "negate"); DEFSYM (QFnumberp, "Fnumberp"); DEFSYM (QFintegerp, "Fintegerp"); commit 15e31a4a1fa359cfabda074903fce79f4982245b Author: Andrea Corallo Date: Thu Aug 15 22:23:32 2019 +0200 fix indent_to diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index d7b4123a21..a95cd56eae 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -597,7 +597,10 @@ the annotation emission." (byte-following-char auto) (byte-preceding-char preceding-char Fprevious_char) (byte-current-column auto) - (byte-indent-to auto) + (byte-indent-to + (comp-emit-set-call `(call Findent_to + ,(comp-slot) + ,(make-comp-mvar :constant nil)))) (byte-scan-buffer-OBSOLETE) (byte-eolp auto) (byte-eobp auto) commit 916a87f0a9748b4c31f20496fff3223553f5226e Author: Andrea Corallo Date: Thu Aug 15 22:01:34 2019 +0200 inline integerp diff --git a/src/comp.c b/src/comp.c index ff0f5699c2..71dda17399 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1386,9 +1386,9 @@ emit_limple_insn (Lisp_Object insn) } -/*******************************/ -/* Code emitters for inlines. */ -/*******************************/ +/**************/ +/* Inliners. */ +/**************/ static gcc_jit_rvalue * emit_add1 (Lisp_Object insn) @@ -1452,6 +1452,15 @@ emit_numperp (Lisp_Object insn) &res); } +static gcc_jit_rvalue * +emit_integerp (Lisp_Object insn) +{ + gcc_jit_rvalue *x = emit_mvar_val (SECOND (insn)); + gcc_jit_rvalue *res = emit_INTEGERP (x); + return gcc_jit_context_new_call (comp.ctxt, NULL, comp.bool_to_lisp_obj, 1, + &res); +} + /****************************************************************/ /* Inline function definition and lisp data structure follows. */ @@ -2329,6 +2338,7 @@ DEFUN ("comp-init-ctxt", Fcomp_init_ctxt, Scomp_init_ctxt, emit_simple_limple_call_void_ret); register_emitter (Qhelper_save_restriction, emit_simple_limple_call_void_ret); + /* Inliners. */ register_emitter (QFadd1, emit_add1); register_emitter (QFsub1, emit_sub1); register_emitter (QFconsp, emit_consp); @@ -2336,6 +2346,7 @@ DEFUN ("comp-init-ctxt", Fcomp_init_ctxt, Scomp_init_ctxt, register_emitter (QFcdr, emit_cdr); register_emitter (Qnegate, emit_negate); register_emitter (QFnumberp, emit_numperp); + register_emitter (QFintegerp, emit_integerp); } comp.ctxt = gcc_jit_context_acquire(); @@ -2745,6 +2756,7 @@ syms_of_comp (void) DEFSYM (QFcdr, "Fcdr"); DEFSYM (Qnegate, "negate"); DEFSYM (QFnumberp, "Fnumberp"); + DEFSYM (QFintegerp, "Fintegerp"); defsubr (&Scomp_init_ctxt); defsubr (&Scomp_release_ctxt); commit d73dd4c12c92db4419df1b96b1562c5c821bf877 Author: Andrea Corallo Date: Thu Aug 15 21:56:35 2019 +0200 inline numberp diff --git a/src/comp.c b/src/comp.c index 4838160d40..ff0f5699c2 100644 --- a/src/comp.c +++ b/src/comp.c @@ -603,32 +603,32 @@ emit_CONSP (gcc_jit_rvalue *obj) return emit_TAGGEDP (obj, Lisp_Cons); } -/* static gcc_jit_rvalue * */ -/* emit_FLOATP (gcc_jit_rvalue *obj) */ -/* { */ -/* emit_comment ("FLOATP"); */ +static gcc_jit_rvalue * +emit_FLOATP (gcc_jit_rvalue *obj) +{ + emit_comment ("FLOATP"); -/* return emit_TAGGEDP (obj, Lisp_Float); */ -/* } */ + return emit_TAGGEDP (obj, Lisp_Float); +} -/* static gcc_jit_rvalue * */ -/* emit_BIGNUMP (gcc_jit_rvalue *obj) */ -/* { */ -/* /\* PSEUDOVECTORP (x, PVEC_BIGNUM); *\/ */ -/* emit_comment ("BIGNUMP"); */ - -/* gcc_jit_rvalue *args[2] = { */ -/* obj, */ -/* gcc_jit_context_new_rvalue_from_int (comp.ctxt, */ -/* comp.int_type, */ -/* PVEC_BIGNUM) }; */ - -/* return gcc_jit_context_new_call (comp.ctxt, */ -/* NULL, */ -/* comp.pseudovectorp, */ -/* 2, */ -/* args); */ -/* } */ +static gcc_jit_rvalue * +emit_BIGNUMP (gcc_jit_rvalue *obj) +{ + /* PSEUDOVECTORP (x, PVEC_BIGNUM); */ + emit_comment ("BIGNUMP"); + + gcc_jit_rvalue *args[2] = { + obj, + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.int_type, + PVEC_BIGNUM) }; + + return gcc_jit_context_new_call (comp.ctxt, + NULL, + comp.pseudovectorp, + 2, + args); +} static gcc_jit_rvalue * emit_FIXNUMP (gcc_jit_rvalue *obj) @@ -692,33 +692,33 @@ emit_XFIXNUM (gcc_jit_rvalue *obj) comp.inttypebits); } -/* static gcc_jit_rvalue * */ -/* emit_INTEGERP (gcc_jit_rvalue *obj) */ -/* { */ -/* emit_comment ("INTEGERP"); */ - -/* return gcc_jit_context_new_binary_op (comp.ctxt, */ -/* NULL, */ -/* GCC_JIT_BINARY_OP_LOGICAL_OR, */ -/* comp.bool_type, */ -/* emit_cast (comp.bool_type, */ -/* emit_FIXNUMP (obj)), */ -/* emit_BIGNUMP (obj)); */ -/* } */ +static gcc_jit_rvalue * +emit_INTEGERP (gcc_jit_rvalue *obj) +{ + emit_comment ("INTEGERP"); -/* static gcc_jit_rvalue * */ -/* emit_NUMBERP (gcc_jit_rvalue *obj) */ -/* { */ -/* emit_comment ("NUMBERP"); */ - -/* return gcc_jit_context_new_binary_op (comp.ctxt, */ -/* NULL, */ -/* GCC_JIT_BINARY_OP_LOGICAL_OR, */ -/* comp.bool_type, */ -/* emit_INTEGERP(obj), */ -/* emit_cast (comp.bool_type, */ -/* emit_FLOATP (obj))); */ -/* } */ + return gcc_jit_context_new_binary_op (comp.ctxt, + NULL, + GCC_JIT_BINARY_OP_LOGICAL_OR, + comp.bool_type, + emit_cast (comp.bool_type, + emit_FIXNUMP (obj)), + emit_BIGNUMP (obj)); +} + +static gcc_jit_rvalue * +emit_NUMBERP (gcc_jit_rvalue *obj) +{ + emit_comment ("NUMBERP"); + + return gcc_jit_context_new_binary_op (comp.ctxt, + NULL, + GCC_JIT_BINARY_OP_LOGICAL_OR, + comp.bool_type, + emit_INTEGERP(obj), + emit_cast (comp.bool_type, + emit_FLOATP (obj))); +} static gcc_jit_rvalue * emit_make_fixnum (gcc_jit_rvalue *obj) @@ -1443,6 +1443,15 @@ emit_cdr (Lisp_Object insn) 1, &x); } +static gcc_jit_rvalue * +emit_numperp (Lisp_Object insn) +{ + gcc_jit_rvalue *x = emit_mvar_val (SECOND (insn)); + gcc_jit_rvalue *res = emit_NUMBERP (x); + return gcc_jit_context_new_call (comp.ctxt, NULL, comp.bool_to_lisp_obj, 1, + &res); +} + /****************************************************************/ /* Inline function definition and lisp data structure follows. */ @@ -2326,6 +2335,7 @@ DEFUN ("comp-init-ctxt", Fcomp_init_ctxt, Scomp_init_ctxt, register_emitter (QFcar, emit_car); register_emitter (QFcdr, emit_cdr); register_emitter (Qnegate, emit_negate); + register_emitter (QFnumberp, emit_numperp); } comp.ctxt = gcc_jit_context_acquire(); @@ -2727,12 +2737,14 @@ syms_of_comp (void) DEFSYM (Qhelper_unbind_n, "helper_unbind_n"); DEFSYM (Qhelper_unwind_protect, "helper_unwind_protect"); DEFSYM (Qhelper_save_restriction, "helper_save_restriction"); + /* Inliners. */ DEFSYM (QFadd1, "Fadd1"); DEFSYM (QFsub1, "Fsub1"); DEFSYM (QFconsp, "Fconsp"); DEFSYM (QFcar, "Fcar"); DEFSYM (QFcdr, "Fcdr"); DEFSYM (Qnegate, "negate"); + DEFSYM (QFnumberp, "Fnumberp"); defsubr (&Scomp_init_ctxt); defsubr (&Scomp_release_ctxt); commit ac036532599bdd49ab3bdd36437a06a12224a620 Author: Andrea Corallo Date: Thu Aug 15 21:32:02 2019 +0200 fix preceding-char diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index d2ead1f164..d7b4123a21 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -595,7 +595,7 @@ the annotation emission." (byte-point-min auto) (byte-char-after auto) (byte-following-char auto) - (byte-preceding-char auto) + (byte-preceding-char preceding-char Fprevious_char) (byte-current-column auto) (byte-indent-to auto) (byte-scan-buffer-OBSOLETE) commit b72d1c5b157214bc8feb4e6364ba624f9feae271 Author: Andrea Corallo Date: Thu Aug 15 21:19:24 2019 +0200 remove duplicate code diff --git a/src/comp.c b/src/comp.c index 6aa86e37a1..4838160d40 100644 --- a/src/comp.c +++ b/src/comp.c @@ -339,7 +339,7 @@ emit_call (const char *f_name, gcc_jit_type *ret_type, unsigned nargs, } static gcc_jit_rvalue * -emit_call_n_ref (const char *f_name, unsigned nargs, +emit_call_ref (const char *f_name, unsigned nargs, gcc_jit_lvalue *base_arg) { gcc_jit_rvalue *args[] = @@ -1092,13 +1092,7 @@ emit_limple_call_ref (Lisp_Object args) char *callee = (char *) SDATA (SYMBOL_NAME (FIRST (args))); EMACS_UINT nargs = XFIXNUM (SECOND (args)); EMACS_UINT base_ptr = XFIXNUM (THIRD (args)); - gcc_jit_rvalue *gcc_args[2] = - { gcc_jit_context_new_rvalue_from_int (comp.ctxt, - comp.ptrdiff_type, - nargs), - gcc_jit_lvalue_get_address (comp.frame[base_ptr], NULL) }; - - return emit_call (callee, comp.lisp_obj_type, 2, gcc_args); + return emit_call_ref (callee, nargs, comp.frame[base_ptr]); } /* Register an handler for a non local exit. */ @@ -2146,7 +2140,7 @@ define_negate (void) emit_make_fixnum (inline_res)); comp.block = fcall_block; - gcc_jit_rvalue *call_res = emit_call_n_ref ("Fminus", 1, n); + gcc_jit_rvalue *call_res = emit_call_ref ("Fminus", 1, n); gcc_jit_block_end_with_return (fcall_block, NULL, call_res); commit 4ed657604d669b4ba05a9280734c5f006939cdab Author: Andrea Corallo Date: Thu Aug 15 21:06:07 2019 +0200 inline negate diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 38511b74bd..d2ead1f164 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -582,7 +582,8 @@ the annotation emission." (byte-leq <= Fleq) (byte-geq >= Fgeq) (byte-diff - Fminus) - (byte-negate - Fminus) + (byte-negate + (comp-emit-set-call `(call negate ,(comp-slot)))) (byte-plus + Fplus) (byte-max auto) (byte-min auto) diff --git a/src/comp.c b/src/comp.c index dd43ed4034..6aa86e37a1 100644 --- a/src/comp.c +++ b/src/comp.c @@ -138,6 +138,7 @@ typedef struct { gcc_jit_function *bool_to_lisp_obj; gcc_jit_function *add1; gcc_jit_function *sub1; + gcc_jit_function *negate; gcc_jit_function *car; gcc_jit_function *cdr; gcc_jit_function *setcar; @@ -337,6 +338,18 @@ emit_call (const char *f_name, gcc_jit_type *ret_type, unsigned nargs, args); } +static gcc_jit_rvalue * +emit_call_n_ref (const char *f_name, unsigned nargs, + gcc_jit_lvalue *base_arg) +{ + gcc_jit_rvalue *args[] = + { gcc_jit_context_new_rvalue_from_int(comp.ctxt, + comp.ptrdiff_type, + nargs), + gcc_jit_lvalue_get_address (base_arg, NULL) }; + return emit_call (f_name, comp.lisp_obj_type, 2, args); +} + /* Close current basic block emitting a conditional. */ INLINE static void @@ -1397,6 +1410,13 @@ emit_sub1 (Lisp_Object insn) return gcc_jit_context_new_call (comp.ctxt, NULL, comp.sub1, 1, &n); } +static gcc_jit_rvalue * +emit_negate (Lisp_Object insn) +{ + gcc_jit_rvalue *n = emit_mvar_val (SECOND (insn)); + return gcc_jit_context_new_call (comp.ctxt, NULL, comp.negate, 1, &n); +} + static gcc_jit_rvalue * emit_consp (Lisp_Object insn) { @@ -1804,11 +1824,11 @@ define_CHECK_TYPE (void) gcc_jit_rvalue *predicate = gcc_jit_param_as_rvalue (param[1]); gcc_jit_rvalue *x = gcc_jit_param_as_rvalue (param[2]); - DECL_BLOCK (init_block, comp.check_type); + DECL_BLOCK (entry_block, comp.check_type); DECL_BLOCK (ok_block, comp.check_type); DECL_BLOCK (not_ok_block, comp.check_type); - comp.block = init_block; + comp.block = entry_block; comp.func = comp.check_type; emit_cond_jump (ok, ok_block, not_ok_block); @@ -1865,11 +1885,11 @@ define_CAR_CDR (void) for (int i = 0; i < 2; i++) { gcc_jit_rvalue *c = gcc_jit_param_as_rvalue (param); - DECL_BLOCK (init_block, f); + DECL_BLOCK (entry_block, f); DECL_BLOCK (is_cons_b, f); DECL_BLOCK (not_a_cons_b, f); - comp.block = init_block; + comp.block = entry_block; comp.func = f; emit_cond_jump (emit_CONSP (c), is_cons_b, not_a_cons_b); @@ -1942,9 +1962,9 @@ define_setcar_setcdr (void) 2, param, 0); - DECL_BLOCK (init_block, *f_ref); + DECL_BLOCK (entry_block, *f_ref); comp.func = *f_ref; - comp.block = init_block; + comp.block = entry_block; /* CHECK_CONS (cell); */ emit_CHECK_CONS (gcc_jit_param_as_rvalue (cell)); @@ -1955,7 +1975,7 @@ define_setcar_setcdr (void) emit_XCONS (gcc_jit_param_as_rvalue (cell)) }; gcc_jit_block_add_eval ( - init_block, + entry_block, NULL, gcc_jit_context_new_call (comp.ctxt, NULL, @@ -1972,7 +1992,7 @@ define_setcar_setcdr (void) gcc_jit_param_as_rvalue (new_el)); /* return newel; */ - gcc_jit_block_end_with_return (init_block, + gcc_jit_block_end_with_return (entry_block, NULL, gcc_jit_param_as_rvalue (new_el)); } @@ -2009,11 +2029,11 @@ define_add1_sub1 (void) 1, ¶m, 0); - DECL_BLOCK (init_block, func[i]); + DECL_BLOCK (entry_block, func[i]); DECL_BLOCK (inline_block, func[i]); DECL_BLOCK (fcall_block, func[i]); - comp.block = init_block; + comp.block = entry_block; /* (FIXNUMP (n) && XFIXNUM (n) != MOST_POSITIVE_FIXNUM ? (XFIXNUM (n) + 1) @@ -2063,6 +2083,76 @@ define_add1_sub1 (void) comp.sub1 = func[1]; } +static void +define_negate (void) +{ + gcc_jit_block *bb_orig = comp.block; + + gcc_jit_param *param[] = + { gcc_jit_context_new_param (comp.ctxt, + NULL, + comp.lisp_obj_type, + "n") }; + + comp.func = comp.negate = + gcc_jit_context_new_function (comp.ctxt, NULL, + GCC_JIT_FUNCTION_ALWAYS_INLINE, + comp.lisp_obj_type, + "negate", + 1, + param, + 0); + + DECL_BLOCK (entry_block, comp.negate); + DECL_BLOCK (inline_block, comp.negate); + DECL_BLOCK (fcall_block, comp.negate); + + comp.block = entry_block; + + /* (FIXNUMP (TOP) && XFIXNUM (TOP) != MOST_NEGATIVE_FIXNUM + ? make_fixnum (- XFIXNUM (TOP)) + : Fminus (1, &TOP)) */ + + gcc_jit_lvalue *n = gcc_jit_param_as_lvalue (param[0]); + gcc_jit_rvalue *n_fixnum = + emit_XFIXNUM (gcc_jit_lvalue_as_rvalue (n)); + + emit_cond_jump ( + gcc_jit_context_new_binary_op ( + comp.ctxt, + NULL, + GCC_JIT_BINARY_OP_LOGICAL_AND, + comp.bool_type, + emit_cast (comp.bool_type, + emit_FIXNUMP (gcc_jit_lvalue_as_rvalue (n))), + gcc_jit_context_new_comparison (comp.ctxt, + NULL, + GCC_JIT_COMPARISON_NE, + n_fixnum, + comp.most_negative_fixnum)), + inline_block, + fcall_block); + + comp.block = inline_block; + gcc_jit_rvalue *inline_res = + gcc_jit_context_new_unary_op (comp.ctxt, + NULL, + GCC_JIT_UNARY_OP_MINUS, + comp.emacs_int_type, + n_fixnum); + + gcc_jit_block_end_with_return (inline_block, + NULL, + emit_make_fixnum (inline_res)); + + comp.block = fcall_block; + gcc_jit_rvalue *call_res = emit_call_n_ref ("Fminus", 1, n); + gcc_jit_block_end_with_return (fcall_block, + NULL, + call_res); + comp.block = bb_orig; +} + /* Define a substitute for PSEUDOVECTORP as always inlined function. */ static void @@ -2087,11 +2177,11 @@ define_PSEUDOVECTORP (void) param, 0); - DECL_BLOCK (init_block, comp.pseudovectorp); + DECL_BLOCK (entry_block, comp.pseudovectorp); DECL_BLOCK (ret_false_b, comp.pseudovectorp); DECL_BLOCK (call_pseudovector_typep_b, comp.pseudovectorp); - comp.block = init_block; + comp.block = entry_block; comp.func = comp.pseudovectorp; emit_cond_jump (emit_VECTORLIKEP (gcc_jit_param_as_rvalue (param[0])), @@ -2141,11 +2231,11 @@ define_CHECK_IMPURE (void) param, 0); - DECL_BLOCK (init_block, comp.check_impure); + DECL_BLOCK (entry_block, comp.check_impure); DECL_BLOCK (err_block, comp.check_impure); DECL_BLOCK (ok_block, comp.check_impure); - comp.block = init_block; + comp.block = entry_block; comp.func = comp.check_impure; emit_cond_jump (emit_PURE_P (gcc_jit_param_as_rvalue (param[0])), /* FIXME */ @@ -2184,10 +2274,10 @@ define_bool_to_lisp_obj (void) 1, ¶m, 0); - DECL_BLOCK (init_block, comp.bool_to_lisp_obj); + DECL_BLOCK (entry_block, comp.bool_to_lisp_obj); DECL_BLOCK (ret_t_block, comp.bool_to_lisp_obj); DECL_BLOCK (ret_nil_block, comp.bool_to_lisp_obj); - comp.block = init_block; + comp.block = entry_block; comp.func = comp.bool_to_lisp_obj; emit_cond_jump (gcc_jit_param_as_rvalue (param), @@ -2241,6 +2331,7 @@ DEFUN ("comp-init-ctxt", Fcomp_init_ctxt, Scomp_init_ctxt, register_emitter (QFconsp, emit_consp); register_emitter (QFcar, emit_car); register_emitter (QFcdr, emit_cdr); + register_emitter (Qnegate, emit_negate); } comp.ctxt = gcc_jit_context_acquire(); @@ -2383,6 +2474,7 @@ DEFUN ("comp-init-ctxt", Fcomp_init_ctxt, Scomp_init_ctxt, define_bool_to_lisp_obj (); define_setcar_setcdr (); define_add1_sub1 (); + define_negate (); return Qt; } @@ -2646,6 +2738,7 @@ syms_of_comp (void) DEFSYM (QFconsp, "Fconsp"); DEFSYM (QFcar, "Fcar"); DEFSYM (QFcdr, "Fcdr"); + DEFSYM (Qnegate, "negate"); defsubr (&Scomp_init_ctxt); defsubr (&Scomp_release_ctxt); commit 92fc5baf17ccd0999f631d469708523de50ac06e Author: Andrea Corallo Date: Thu Aug 15 18:49:36 2019 +0200 inline car cdr diff --git a/src/comp.c b/src/comp.c index fed777e9e0..dd43ed4034 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1409,6 +1409,26 @@ emit_consp (Lisp_Object insn) 1, &res); } +static gcc_jit_rvalue * +emit_car (Lisp_Object insn) +{ + gcc_jit_rvalue *x = emit_mvar_val (SECOND (insn)); + return gcc_jit_context_new_call (comp.ctxt, + NULL, + comp.car, + 1, &x); +} + +static gcc_jit_rvalue * +emit_cdr (Lisp_Object insn) +{ + gcc_jit_rvalue *x = emit_mvar_val (SECOND (insn)); + return gcc_jit_context_new_call (comp.ctxt, + NULL, + comp.cdr, + 1, &x); +} + /****************************************************************/ /* Inline function definition and lisp data structure follows. */ @@ -2219,6 +2239,8 @@ DEFUN ("comp-init-ctxt", Fcomp_init_ctxt, Scomp_init_ctxt, register_emitter (QFadd1, emit_add1); register_emitter (QFsub1, emit_sub1); register_emitter (QFconsp, emit_consp); + register_emitter (QFcar, emit_car); + register_emitter (QFcdr, emit_cdr); } comp.ctxt = gcc_jit_context_acquire(); @@ -2622,6 +2644,8 @@ syms_of_comp (void) DEFSYM (QFadd1, "Fadd1"); DEFSYM (QFsub1, "Fsub1"); DEFSYM (QFconsp, "Fconsp"); + DEFSYM (QFcar, "Fcar"); + DEFSYM (QFcdr, "Fcdr"); defsubr (&Scomp_init_ctxt); defsubr (&Scomp_release_ctxt); commit b30bbf030bacdb0b66c0296d1368db7b4c07558c Author: Andrea Corallo Date: Thu Aug 15 18:40:42 2019 +0200 inline consp diff --git a/src/comp.c b/src/comp.c index fa242a85e3..fed777e9e0 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1397,6 +1397,18 @@ emit_sub1 (Lisp_Object insn) return gcc_jit_context_new_call (comp.ctxt, NULL, comp.sub1, 1, &n); } +static gcc_jit_rvalue * +emit_consp (Lisp_Object insn) +{ + gcc_jit_rvalue *x = emit_mvar_val (SECOND (insn)); + gcc_jit_rvalue *res = emit_cast (comp.bool_type, + emit_CONSP (x)); + return gcc_jit_context_new_call (comp.ctxt, + NULL, + comp.bool_to_lisp_obj, + 1, &res); +} + /****************************************************************/ /* Inline function definition and lisp data structure follows. */ @@ -2206,6 +2218,7 @@ DEFUN ("comp-init-ctxt", Fcomp_init_ctxt, Scomp_init_ctxt, emit_simple_limple_call_void_ret); register_emitter (QFadd1, emit_add1); register_emitter (QFsub1, emit_sub1); + register_emitter (QFconsp, emit_consp); } comp.ctxt = gcc_jit_context_acquire(); @@ -2608,6 +2621,7 @@ syms_of_comp (void) DEFSYM (Qhelper_save_restriction, "helper_save_restriction"); DEFSYM (QFadd1, "Fadd1"); DEFSYM (QFsub1, "Fsub1"); + DEFSYM (QFconsp, "Fconsp"); defsubr (&Scomp_init_ctxt); defsubr (&Scomp_release_ctxt); commit 643771818e36a8448744f061184cb3411b13291e Author: Andrea Corallo Date: Thu Aug 15 18:29:36 2019 +0200 inline sub1 diff --git a/src/comp.c b/src/comp.c index 95390c5263..fa242a85e3 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1390,6 +1390,13 @@ emit_add1 (Lisp_Object insn) return gcc_jit_context_new_call (comp.ctxt, NULL, comp.add1, 1, &n); } +static gcc_jit_rvalue * +emit_sub1 (Lisp_Object insn) +{ + gcc_jit_rvalue *n = emit_mvar_val (SECOND (insn)); + return gcc_jit_context_new_call (comp.ctxt, NULL, comp.sub1, 1, &n); +} + /****************************************************************/ /* Inline function definition and lisp data structure follows. */ @@ -1949,69 +1956,79 @@ define_add1_sub1 (void) { gcc_jit_block *bb_orig = comp.block; - gcc_jit_param *param[] = - { gcc_jit_context_new_param (comp.ctxt, - NULL, - comp.lisp_obj_type, - "n") }; - - comp.func = comp.add1 = - gcc_jit_context_new_function (comp.ctxt, NULL, - GCC_JIT_FUNCTION_ALWAYS_INLINE, - comp.lisp_obj_type, - "add1", - 1, - param, - 0); - - DECL_BLOCK (init_block, comp.add1); - DECL_BLOCK (add1_inline_block, comp.add1); - DECL_BLOCK (add1_fcall_block, comp.add1); + gcc_jit_function *func[2]; + char const *f_name[] = {"add1", "sub1"}; + char const *fall_back_func[] = {"Fadd1", "Fsub1"}; + gcc_jit_rvalue *compare[] = + { comp.most_positive_fixnum, comp.most_negative_fixnum }; + enum gcc_jit_binary_op op[] = + { GCC_JIT_BINARY_OP_PLUS, GCC_JIT_BINARY_OP_MINUS }; + for (int i = 0; i < 2; i++) + { + gcc_jit_param *param = gcc_jit_context_new_param (comp.ctxt, + NULL, + comp.lisp_obj_type, + "n"); + comp.func = func[i] = + gcc_jit_context_new_function (comp.ctxt, NULL, + GCC_JIT_FUNCTION_ALWAYS_INLINE, + comp.lisp_obj_type, + f_name[i], + 1, + ¶m, + 0); + DECL_BLOCK (init_block, func[i]); + DECL_BLOCK (inline_block, func[i]); + DECL_BLOCK (fcall_block, func[i]); - comp.block = init_block; + comp.block = init_block; - /* (FIXNUMP (n) && XFIXNUM (n) != MOST_POSITIVE_FIXNUM - ? (XFIXNUM (n) + 1) - : Fadd1 (n)) */ + /* (FIXNUMP (n) && XFIXNUM (n) != MOST_POSITIVE_FIXNUM + ? (XFIXNUM (n) + 1) + : Fadd1 (n)) */ - gcc_jit_rvalue *n = gcc_jit_param_as_rvalue (param[0]); - gcc_jit_rvalue *n_fixnum = emit_XFIXNUM (n); + gcc_jit_rvalue *n = gcc_jit_param_as_rvalue (param); + gcc_jit_rvalue *n_fixnum = emit_XFIXNUM (n); - emit_cond_jump ( - gcc_jit_context_new_binary_op ( - comp.ctxt, - NULL, - GCC_JIT_BINARY_OP_LOGICAL_AND, - comp.bool_type, - emit_cast (comp.bool_type, + emit_cond_jump ( + gcc_jit_context_new_binary_op ( + comp.ctxt, + NULL, + GCC_JIT_BINARY_OP_LOGICAL_AND, + comp.bool_type, + emit_cast (comp.bool_type, emit_FIXNUMP (n)), - gcc_jit_context_new_comparison (comp.ctxt, - NULL, - GCC_JIT_COMPARISON_NE, - n_fixnum, - comp.most_positive_fixnum)), - add1_inline_block, - add1_fcall_block); - - comp.block = add1_inline_block; - gcc_jit_rvalue *inline_res = - gcc_jit_context_new_binary_op (comp.ctxt, - NULL, - GCC_JIT_BINARY_OP_PLUS, - comp.emacs_int_type, - n_fixnum, - comp.one); + gcc_jit_context_new_comparison (comp.ctxt, + NULL, + GCC_JIT_COMPARISON_NE, + n_fixnum, + compare[i])), + inline_block, + fcall_block); + + comp.block = inline_block; + gcc_jit_rvalue *inline_res = + gcc_jit_context_new_binary_op (comp.ctxt, + NULL, + op[i], + comp.emacs_int_type, + n_fixnum, + comp.one); - gcc_jit_block_end_with_return (add1_inline_block, - NULL, - emit_make_fixnum (inline_res)); + gcc_jit_block_end_with_return (inline_block, + NULL, + emit_make_fixnum (inline_res)); - comp.block = add1_fcall_block; - gcc_jit_rvalue *call_res = emit_call ("Fadd1", comp.lisp_obj_type, 1, &n); - gcc_jit_block_end_with_return (add1_fcall_block, - NULL, - call_res); + comp.block = fcall_block; + gcc_jit_rvalue *call_res = emit_call (fall_back_func[i], + comp.lisp_obj_type, 1, &n); + gcc_jit_block_end_with_return (fcall_block, + NULL, + call_res); + } comp.block = bb_orig; + comp.add1 = func[0]; + comp.sub1 = func[1]; } /* Define a substitute for PSEUDOVECTORP as always inlined function. */ @@ -2188,6 +2205,7 @@ DEFUN ("comp-init-ctxt", Fcomp_init_ctxt, Scomp_init_ctxt, register_emitter (Qhelper_save_restriction, emit_simple_limple_call_void_ret); register_emitter (QFadd1, emit_add1); + register_emitter (QFsub1, emit_sub1); } comp.ctxt = gcc_jit_context_acquire(); @@ -2588,7 +2606,8 @@ syms_of_comp (void) DEFSYM (Qhelper_unbind_n, "helper_unbind_n"); DEFSYM (Qhelper_unwind_protect, "helper_unwind_protect"); DEFSYM (Qhelper_save_restriction, "helper_save_restriction"); - DEFSYM (QFadd1, "Fadd1") + DEFSYM (QFadd1, "Fadd1"); + DEFSYM (QFsub1, "Fsub1"); defsubr (&Scomp_init_ctxt); defsubr (&Scomp_release_ctxt); commit af51e6556daaa4e847209f79ac9dbc1a3ecc8836 Author: Andrea Corallo Date: Thu Aug 15 17:43:58 2019 +0200 inline add1 diff --git a/src/comp.c b/src/comp.c index 8a9d98fde5..95390c5263 100644 --- a/src/comp.c +++ b/src/comp.c @@ -136,6 +136,8 @@ typedef struct { gcc_jit_rvalue *lisp_int0; gcc_jit_function *pseudovectorp; gcc_jit_function *bool_to_lisp_obj; + gcc_jit_function *add1; + gcc_jit_function *sub1; gcc_jit_function *car; gcc_jit_function *cdr; gcc_jit_function *setcar; @@ -615,67 +617,67 @@ emit_CONSP (gcc_jit_rvalue *obj) /* args); */ /* } */ -/* static gcc_jit_rvalue * */ -/* emit_FIXNUMP (gcc_jit_rvalue *obj) */ -/* { */ -/* /\* (! (((unsigned) (XLI (x) >> (USE_LSB_TAG ? 0 : FIXNUM_BITS)) */ -/* - (unsigned) (Lisp_Int0 >> !USE_LSB_TAG)) */ -/* & ((1 << INTTYPEBITS) - 1))) *\/ */ -/* emit_comment ("FIXNUMP"); */ - -/* gcc_jit_rvalue *sh_res = */ -/* gcc_jit_context_new_binary_op ( */ -/* comp.ctxt, */ -/* NULL, */ -/* GCC_JIT_BINARY_OP_RSHIFT, */ -/* comp.emacs_int_type, */ -/* emit_XLI (obj), */ -/* gcc_jit_context_new_rvalue_from_int (comp.ctxt, */ -/* comp.emacs_int_type, */ -/* (USE_LSB_TAG ? 0 : FIXNUM_BITS))); */ - -/* gcc_jit_rvalue *minus_res = */ -/* gcc_jit_context_new_binary_op (comp.ctxt, */ -/* NULL, */ -/* GCC_JIT_BINARY_OP_MINUS, */ -/* comp.unsigned_type, */ -/* emit_cast (comp.unsigned_type, sh_res), */ -/* gcc_jit_context_new_rvalue_from_int ( */ -/* comp.ctxt, */ -/* comp.unsigned_type, */ -/* (Lisp_Int0 >> !USE_LSB_TAG))); */ - -/* gcc_jit_rvalue *res = */ -/* gcc_jit_context_new_unary_op ( */ -/* comp.ctxt, */ -/* NULL, */ -/* GCC_JIT_UNARY_OP_LOGICAL_NEGATE, */ -/* comp.int_type, */ -/* gcc_jit_context_new_binary_op (comp.ctxt, */ -/* NULL, */ -/* GCC_JIT_BINARY_OP_BITWISE_AND, */ -/* comp.unsigned_type, */ -/* minus_res, */ -/* gcc_jit_context_new_rvalue_from_int ( */ -/* comp.ctxt, */ -/* comp.unsigned_type, */ -/* ((1 << INTTYPEBITS) - 1)))); */ - -/* return res; */ -/* } */ +static gcc_jit_rvalue * +emit_FIXNUMP (gcc_jit_rvalue *obj) +{ + /* (! (((unsigned) (XLI (x) >> (USE_LSB_TAG ? 0 : FIXNUM_BITS)) + - (unsigned) (Lisp_Int0 >> !USE_LSB_TAG)) + & ((1 << INTTYPEBITS) - 1))) */ + emit_comment ("FIXNUMP"); -/* static gcc_jit_rvalue * */ -/* emit_XFIXNUM (gcc_jit_rvalue *obj) */ -/* { */ -/* emit_comment ("XFIXNUM"); */ + gcc_jit_rvalue *sh_res = + gcc_jit_context_new_binary_op ( + comp.ctxt, + NULL, + GCC_JIT_BINARY_OP_RSHIFT, + comp.emacs_int_type, + emit_XLI (obj), + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.emacs_int_type, + (USE_LSB_TAG ? 0 : FIXNUM_BITS))); -/* return gcc_jit_context_new_binary_op (comp.ctxt, */ -/* NULL, */ -/* GCC_JIT_BINARY_OP_RSHIFT, */ -/* comp.emacs_int_type, */ -/* emit_XLI (obj), */ -/* comp.inttypebits); */ -/* } */ + gcc_jit_rvalue *minus_res = + gcc_jit_context_new_binary_op (comp.ctxt, + NULL, + GCC_JIT_BINARY_OP_MINUS, + comp.unsigned_type, + emit_cast (comp.unsigned_type, sh_res), + gcc_jit_context_new_rvalue_from_int ( + comp.ctxt, + comp.unsigned_type, + (Lisp_Int0 >> !USE_LSB_TAG))); + + gcc_jit_rvalue *res = + gcc_jit_context_new_unary_op ( + comp.ctxt, + NULL, + GCC_JIT_UNARY_OP_LOGICAL_NEGATE, + comp.int_type, + gcc_jit_context_new_binary_op (comp.ctxt, + NULL, + GCC_JIT_BINARY_OP_BITWISE_AND, + comp.unsigned_type, + minus_res, + gcc_jit_context_new_rvalue_from_int ( + comp.ctxt, + comp.unsigned_type, + ((1 << INTTYPEBITS) - 1)))); + + return res; +} + +static gcc_jit_rvalue * +emit_XFIXNUM (gcc_jit_rvalue *obj) +{ + emit_comment ("XFIXNUM"); + + return gcc_jit_context_new_binary_op (comp.ctxt, + NULL, + GCC_JIT_BINARY_OP_RSHIFT, + comp.emacs_int_type, + emit_XLI (obj), + comp.inttypebits); +} /* static gcc_jit_rvalue * */ /* emit_INTEGERP (gcc_jit_rvalue *obj) */ @@ -705,38 +707,38 @@ emit_CONSP (gcc_jit_rvalue *obj) /* emit_FLOATP (obj))); */ /* } */ -/* static gcc_jit_rvalue * */ -/* emit_make_fixnum (gcc_jit_rvalue *obj) */ -/* { */ -/* emit_comment ("make_fixnum"); */ +static gcc_jit_rvalue * +emit_make_fixnum (gcc_jit_rvalue *obj) +{ + emit_comment ("make_fixnum"); -/* gcc_jit_rvalue *tmp = */ -/* gcc_jit_context_new_binary_op (comp.ctxt, */ -/* NULL, */ -/* GCC_JIT_BINARY_OP_LSHIFT, */ -/* comp.emacs_int_type, */ -/* obj, */ -/* comp.inttypebits); */ - -/* tmp = gcc_jit_context_new_binary_op (comp.ctxt, */ -/* NULL, */ -/* GCC_JIT_BINARY_OP_PLUS, */ -/* comp.emacs_int_type, */ -/* tmp, */ -/* comp.lisp_int0); */ - -/* gcc_jit_lvalue *res = gcc_jit_function_new_local (comp.func, */ -/* NULL, */ -/* comp.lisp_obj_type, */ -/* "lisp_obj_fixnum"); */ - -/* gcc_jit_block_add_assignment (comp.block, */ -/* NULL, */ -/* emit_lval_XLI (res), */ -/* tmp); */ - -/* return gcc_jit_lvalue_as_rvalue (res); */ -/* } */ + gcc_jit_rvalue *tmp = + gcc_jit_context_new_binary_op (comp.ctxt, + NULL, + GCC_JIT_BINARY_OP_LSHIFT, + comp.emacs_int_type, + obj, + comp.inttypebits); + + tmp = gcc_jit_context_new_binary_op (comp.ctxt, + NULL, + GCC_JIT_BINARY_OP_PLUS, + comp.emacs_int_type, + tmp, + comp.lisp_int0); + + gcc_jit_lvalue *res = gcc_jit_function_new_local (comp.func, + NULL, + comp.lisp_obj_type, + "lisp_obj_fixnum"); + + gcc_jit_block_add_assignment (comp.block, + NULL, + emit_lval_XLI (res), + tmp); + + return gcc_jit_lvalue_as_rvalue (res); +} /* Construct fill and return a lisp object form a raw pointer. */ static gcc_jit_rvalue * @@ -1376,6 +1378,18 @@ emit_limple_insn (Lisp_Object insn) } } + +/*******************************/ +/* Code emitters for inlines. */ +/*******************************/ + +static gcc_jit_rvalue * +emit_add1 (Lisp_Object insn) +{ + gcc_jit_rvalue *n = emit_mvar_val (SECOND (insn)); + return gcc_jit_context_new_call (comp.ctxt, NULL, comp.add1, 1, &n); +} + /****************************************************************/ /* Inline function definition and lisp data structure follows. */ @@ -1774,8 +1788,7 @@ define_CHECK_TYPE (void) gcc_jit_block_end_with_void_return (not_ok_block, NULL); } - -/* Declare a substitute for CAR as always inlined function. */ +/* Define a substitute for CAR as always inlined function. */ static void define_CAR_CDR (void) @@ -1926,7 +1939,82 @@ define_setcar_setcdr (void) } } -/* Declare a substitute for PSEUDOVECTORP as always inlined function. */ +/* + Define a substitute for Fadd1 Fsub1. + Currently expose just fixnum arithmetic. +*/ + +static void +define_add1_sub1 (void) +{ + gcc_jit_block *bb_orig = comp.block; + + gcc_jit_param *param[] = + { gcc_jit_context_new_param (comp.ctxt, + NULL, + comp.lisp_obj_type, + "n") }; + + comp.func = comp.add1 = + gcc_jit_context_new_function (comp.ctxt, NULL, + GCC_JIT_FUNCTION_ALWAYS_INLINE, + comp.lisp_obj_type, + "add1", + 1, + param, + 0); + + DECL_BLOCK (init_block, comp.add1); + DECL_BLOCK (add1_inline_block, comp.add1); + DECL_BLOCK (add1_fcall_block, comp.add1); + + comp.block = init_block; + + /* (FIXNUMP (n) && XFIXNUM (n) != MOST_POSITIVE_FIXNUM + ? (XFIXNUM (n) + 1) + : Fadd1 (n)) */ + + gcc_jit_rvalue *n = gcc_jit_param_as_rvalue (param[0]); + gcc_jit_rvalue *n_fixnum = emit_XFIXNUM (n); + + emit_cond_jump ( + gcc_jit_context_new_binary_op ( + comp.ctxt, + NULL, + GCC_JIT_BINARY_OP_LOGICAL_AND, + comp.bool_type, + emit_cast (comp.bool_type, + emit_FIXNUMP (n)), + gcc_jit_context_new_comparison (comp.ctxt, + NULL, + GCC_JIT_COMPARISON_NE, + n_fixnum, + comp.most_positive_fixnum)), + add1_inline_block, + add1_fcall_block); + + comp.block = add1_inline_block; + gcc_jit_rvalue *inline_res = + gcc_jit_context_new_binary_op (comp.ctxt, + NULL, + GCC_JIT_BINARY_OP_PLUS, + comp.emacs_int_type, + n_fixnum, + comp.one); + + gcc_jit_block_end_with_return (add1_inline_block, + NULL, + emit_make_fixnum (inline_res)); + + comp.block = add1_fcall_block; + gcc_jit_rvalue *call_res = emit_call ("Fadd1", comp.lisp_obj_type, 1, &n); + gcc_jit_block_end_with_return (add1_fcall_block, + NULL, + call_res); + comp.block = bb_orig; +} + +/* Define a substitute for PSEUDOVECTORP as always inlined function. */ static void define_PSEUDOVECTORP (void) @@ -2029,7 +2117,7 @@ define_CHECK_IMPURE (void) gcc_jit_block_end_with_void_return (err_block, NULL); } -/* Declare a function to convert boolean into t or nil */ +/* Define a function to convert boolean into t or nil */ static void define_bool_to_lisp_obj (void) @@ -2099,6 +2187,7 @@ DEFUN ("comp-init-ctxt", Fcomp_init_ctxt, Scomp_init_ctxt, emit_simple_limple_call_void_ret); register_emitter (Qhelper_save_restriction, emit_simple_limple_call_void_ret); + register_emitter (QFadd1, emit_add1); } comp.ctxt = gcc_jit_context_acquire(); @@ -2239,7 +2328,8 @@ DEFUN ("comp-init-ctxt", Fcomp_init_ctxt, Scomp_init_ctxt, define_CHECK_TYPE (); define_CHECK_IMPURE (); define_bool_to_lisp_obj (); - define_setcar_setcdr(); + define_setcar_setcdr (); + define_add1_sub1 (); return Qt; } @@ -2497,7 +2587,8 @@ syms_of_comp (void) DEFSYM (Qrecord_unwind_protect_excursion, "record_unwind_protect_excursion"); DEFSYM (Qhelper_unbind_n, "helper_unbind_n"); DEFSYM (Qhelper_unwind_protect, "helper_unwind_protect"); - DEFSYM (Qhelper_save_restriction, "helper_save_restriction") + DEFSYM (Qhelper_save_restriction, "helper_save_restriction"); + DEFSYM (QFadd1, "Fadd1") defsubr (&Scomp_init_ctxt); defsubr (&Scomp_release_ctxt); commit 757a95906805b1d7fcbe4b536841a7b53ce0c047 Author: Andrea Corallo Date: Sun Aug 11 19:08:18 2019 +0200 some renaming diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 98c6e866ad..38511b74bd 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -741,7 +741,7 @@ the annotation emission." (if (comp-args-p args) (cl-loop for i below (comp-args-max args) do (cl-incf (comp-sp)) - do (comp-emit `(setpar ,(comp-slot) ,i))) + do (comp-emit `(set-par-to-local ,(comp-slot) ,i))) (let ((nonrest (comp-nargs-nonrest args))) (comp-emit-narg-prologue args-min nonrest) (cl-incf (comp-sp) (1+ nonrest)))) diff --git a/src/comp.c b/src/comp.c index f77a1740fe..8a9d98fde5 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1271,7 +1271,7 @@ emit_limple_insn (Lisp_Object insn) comp.frame[slot_n], res); } - else if (EQ (op, Qsetpar)) + else if (EQ (op, Qset_par_to_local)) { /* Ex: (setpar #s(comp-mvar 2 0 nil nil nil) 0). */ EMACS_UINT slot_n = XFIXNUM (FUNCALL1 (comp-mvar-slot, arg0)); @@ -2475,15 +2475,17 @@ syms_of_comp (void) DEFSYM (Qcall, "call"); DEFSYM (Qcallref, "callref"); DEFSYM (Qncall, "ncall"); - DEFSYM (Qsetpar, "setpar"); DEFSYM (Qsetimm, "setimm"); DEFSYM (Qreturn, "return"); DEFSYM (Qcomp_mvar, "comp-mvar"); DEFSYM (Qcond_jump, "cond-jump"); + /* Used during prologue emission. */ + DEFSYM (Qset_par_to_local, "set-par-to-local"); DEFSYM (Qset_args_to_local, "set-args-to-local"); DEFSYM (Qset_rest_args_to_local, "set-rest-args-to-local"); DEFSYM (Qinc_args, "inc-args"); DEFSYM (Qcond_jump_narg_leq, "cond-jump-narg-leq"); + /* Others. */ DEFSYM (Qpush_handler, "push-handler"); DEFSYM (Qpop_handler, "pop-handler"); DEFSYM (Qcondition_case, "condition-case"); commit ab69bb63641d12f8a53a262f37908d8234935e13 Author: Andrea Corallo Date: Sun Aug 11 19:03:06 2019 +0200 some minors diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 0a8ab551eb..98c6e866ad 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -287,7 +287,7 @@ Restore the original value afterwards." (defun comp-emit-set-call (call) "Emit CALL assigning the result the the current slot frame. -If the calle function is known to have a return type propagate it." +If the callee function is known to have a return type propagate it." (cl-assert call) (setf (comp-slot) (make-comp-mvar :slot (comp-sp) @@ -701,13 +701,13 @@ the annotation emission." (comp-stack-adjust (- arg)) (comp-copy-slot (+ arg (comp-sp))))))) -(defun comp-emit-narg-prologue (args-min non-rest) +(defun comp-emit-narg-prologue (minarg nonrest) "Emit the prologue for a narg function." - (cl-loop for i below args-min + (cl-loop for i below minarg do (progn (comp-emit `(set-args-to-local ,i)) (comp-emit '(inc-args)))) - (cl-loop for i from args-min below non-rest + (cl-loop for i from minarg below nonrest for bb = (intern (format "entry_%s" i)) for fallback = (intern (format "entry_fallback_%s" i)) do (progn @@ -717,12 +717,12 @@ the annotation emission." (comp-emit `(set-args-to-local ,i)) (comp-emit '(inc-args))) finally (comp-emit-jump 'entry_rest_args)) - (cl-loop for i from args-min below non-rest + (cl-loop for i from minarg below nonrest do (comp-with-sp i (comp-emit-block (intern (format "entry_fallback_%s" i))) (comp-emit-set-const nil))) (comp-emit-block 'entry_rest_args) - (comp-emit `(set-rest-args-to-local ,non-rest))) + (comp-emit `(set-rest-args-to-local ,nonrest))) (defun comp-limplify (func) "Given FUNC compute its LIMPLE ir." diff --git a/src/comp.c b/src/comp.c index acc727c772..f77a1740fe 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1019,14 +1019,14 @@ static gcc_jit_rvalue * emit_simple_limple_call (Lisp_Object args, gcc_jit_type *ret_type) { int i = 0; - char *calle = (char *) SDATA (SYMBOL_NAME (FIRST (args))); + char *callee = (char *) SDATA (SYMBOL_NAME (FIRST (args))); args = XCDR (args); ptrdiff_t nargs = list_length (args); gcc_jit_rvalue *gcc_args[nargs]; FOR_EACH_TAIL (args) gcc_args[i++] = emit_mvar_val (XCAR (args)); - return emit_call (calle, ret_type, nargs, gcc_args); + return emit_call (callee, ret_type, nargs, gcc_args); } static gcc_jit_rvalue * @@ -1052,16 +1052,16 @@ emit_simple_limple_call_void_ret (Lisp_Object args) static gcc_jit_rvalue * emit_limple_call (Lisp_Object args) { - Lisp_Object calle_sym = FIRST (args); - char *calle = (char *) SDATA (SYMBOL_NAME (calle_sym)); - Lisp_Object emitter = Fgethash (calle_sym, comp.emitter_dispatcher, Qnil); + Lisp_Object callee_sym = FIRST (args); + char *callee = (char *) SDATA (SYMBOL_NAME (callee_sym)); + Lisp_Object emitter = Fgethash (callee_sym, comp.emitter_dispatcher, Qnil); if (!NILP (emitter)) { gcc_jit_rvalue * (* emitter_ptr) (Lisp_Object) = xmint_pointer (emitter); return emitter_ptr (args); } - else if (calle[0] == 'F') + else if (callee[0] == 'F') { return emit_simple_limple_call_lisp_ret (args); } @@ -1074,7 +1074,7 @@ emit_limple_call_ref (Lisp_Object args) { /* Ex: (callref Fplus 2 0). */ - char *calle = (char *) SDATA (SYMBOL_NAME (FIRST (args))); + char *callee = (char *) SDATA (SYMBOL_NAME (FIRST (args))); EMACS_UINT nargs = XFIXNUM (SECOND (args)); EMACS_UINT base_ptr = XFIXNUM (THIRD (args)); gcc_jit_rvalue *gcc_args[2] = @@ -1083,7 +1083,7 @@ emit_limple_call_ref (Lisp_Object args) nargs), gcc_jit_lvalue_get_address (comp.frame[base_ptr], NULL) }; - return emit_call (calle, comp.lisp_obj_type, 2, gcc_args); + return emit_call (callee, comp.lisp_obj_type, 2, gcc_args); } /* Register an handler for a non local exit. */ @@ -2487,6 +2487,7 @@ syms_of_comp (void) DEFSYM (Qpush_handler, "push-handler"); DEFSYM (Qpop_handler, "pop-handler"); DEFSYM (Qcondition_case, "condition-case"); + /* call operands. */ DEFSYM (Qcatcher, "catcher"); DEFSYM (Qentry, "entry"); DEFSYM (Qset_internal, "set_internal"); commit b6288d1322ec476c156c165496d08e8f782bcb03 Author: Andrea Corallo Date: Sun Aug 11 18:49:26 2019 +0200 improve comp-tests-ffuncall diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 1f15a0bd8b..e7b370c932 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -159,12 +159,21 @@ (ert-deftest comp-tests-ffuncall () "Test calling conventions." - (native-compile #'comp-tests-ffuncall-calle-f) + (defun comp-tests-ffuncall-caller-f () (comp-tests-ffuncall-callee-f 1 2 3)) (should (equal (comp-test-apply #'comp-tests-ffuncall-caller-f) '(1 2 3))) + ;; After it gets compiled + (native-compile #'comp-tests-ffuncall-callee-f) + (should (equal (comp-test-apply #'comp-tests-ffuncall-caller-f) '(1 2 3))) + + ;; Recompiling the caller once with callee already compiled + (defun comp-tests-ffuncall-caller-f () + (comp-tests-ffuncall-callee-f 1 2 3)) + (should (equal (comp-test-apply #'comp-tests-ffuncall-caller-f) '(1 2 3))) + (defun comp-tests-ffuncall-callee-optional-f (a b &optional c d) (list a b c d)) commit 74635dafacb9ebb640a4a69108dabdd897c2498f Author: Andrea Corallo Date: Sun Aug 11 17:21:23 2019 +0200 C support for new prologue mechanism diff --git a/src/comp.c b/src/comp.c index 881a78b3d7..acc727c772 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1013,74 +1013,6 @@ emit_set_internal (Lisp_Object args) return emit_call ("set_internal", comp.void_type , 4, gcc_args); } -static void -emit_limple_ncall_prolog (EMACS_UINT n) -{ - /* - nargs will be known at runtime therfore we emit: - - prologue: - local[0] = *args; - ++args; - . - . - . - local[min_args - 1] = *args; - ++args; - local[min_args] = list (nargs - min_args, args); - bb_1: - . - . - . - */ - gcc_jit_lvalue *nargs = - gcc_jit_param_as_lvalue (gcc_jit_function_get_param (comp.func, 0)); - gcc_jit_lvalue *args = - gcc_jit_param_as_lvalue (gcc_jit_function_get_param (comp.func, 1)); - gcc_jit_rvalue *min_args = - gcc_jit_context_new_rvalue_from_int (comp.ctxt, - comp.ptrdiff_type, - n); - - for (ptrdiff_t i = 0; i < n; ++i) - { - gcc_jit_block_add_assignment (comp.block, - NULL, - comp.frame[i], - gcc_jit_lvalue_as_rvalue ( - gcc_jit_rvalue_dereference ( - gcc_jit_lvalue_as_rvalue (args), - NULL))); - - gcc_jit_block_add_assignment (comp.block, - NULL, - args, - emit_ptr_arithmetic ( - gcc_jit_lvalue_as_rvalue (args), - comp.lisp_obj_ptr_type, - sizeof (Lisp_Object), - comp.one)); - } - - /* - rest arguments - */ - gcc_jit_rvalue *list_args[] = - { gcc_jit_context_new_binary_op (comp.ctxt, - NULL, - GCC_JIT_BINARY_OP_MINUS, - comp.ptrdiff_type, - gcc_jit_lvalue_as_rvalue (nargs), - min_args), - gcc_jit_lvalue_as_rvalue (args) }; - - gcc_jit_block_add_assignment (comp.block, - NULL, - comp.frame[n], - emit_call ("Flist", comp.lisp_obj_type, 2, - list_args)); -} - /* This is for a regular function with arguments as m-var. */ static gcc_jit_rvalue * @@ -1250,6 +1182,28 @@ emit_limple_insn (Lisp_Object insn) emit_cond_jump (emit_EQ (a, b), target2, target1); } + else if (EQ (op, Qcond_jump_narg_leq)) + { + /* + Limple: (cond-jump-narg-less 2 entry_2 entry_fallback_2) + C: if (nargs < 2) goto entry2_fallback; else goto entry_2; + */ + gcc_jit_lvalue *nargs = + gcc_jit_param_as_lvalue (gcc_jit_function_get_param (comp.func, 0)); + gcc_jit_rvalue *n = + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.ptrdiff_type, + XFIXNUM (arg0)); + gcc_jit_block *target1 = retrive_block (SECOND (args)); + gcc_jit_block *target2 = retrive_block (THIRD (args)); + gcc_jit_rvalue *test = gcc_jit_context_new_comparison ( + comp.ctxt, + NULL, + GCC_JIT_COMPARISON_LE, + gcc_jit_lvalue_as_rvalue (nargs), + n); + emit_cond_jump (test, target2, target1); + } else if (EQ (op, Qpush_handler)) { EMACS_UINT clobber_slot = XFIXNUM (FUNCALL1 (comp-mvar-slot, arg0)); @@ -1272,8 +1226,10 @@ emit_limple_insn (Lisp_Object insn) } else if (EQ (op, Qpop_handler)) { - /* current_thread->m_handlerlist = - current_thread->m_handlerlist->next; */ + /* + C: current_thread->m_handlerlist = + current_thread->m_handlerlist->next; + */ gcc_jit_lvalue *m_handlerlist = gcc_jit_rvalue_dereference_field (comp.current_thread, NULL, @@ -1328,10 +1284,74 @@ emit_limple_insn (Lisp_Object insn) comp.frame[slot_n], param); } - else if (EQ (op, Qncall_prolog)) + else if (EQ (op, Qset_args_to_local)) + { + /* + Limple: (set-args-to-local 1) + C: local[1] = *args; + */ + gcc_jit_rvalue *gcc_args = + gcc_jit_lvalue_as_rvalue ( + gcc_jit_param_as_lvalue (gcc_jit_function_get_param (comp.func, 1))); + + gcc_jit_rvalue *res = + gcc_jit_lvalue_as_rvalue (gcc_jit_rvalue_dereference (gcc_args, NULL)); + + EMACS_UINT slot_n = XFIXNUM (arg0); + gcc_jit_block_add_assignment (comp.block, + NULL, + comp.frame[slot_n], + res); + } + else if (EQ (op, Qset_rest_args_to_local)) { - /* Ex: (ncall-prolog 2). */ - emit_limple_ncall_prolog (XFIXNUM (arg0)); + /* + Limple: (set-rest-args-to-local 3) + C: local[3] = list (nargs - 3, args); + */ + gcc_jit_rvalue *n = + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.ptrdiff_type, + XFIXNUM (arg0)); + gcc_jit_lvalue *nargs = + gcc_jit_param_as_lvalue (gcc_jit_function_get_param (comp.func, 0)); + gcc_jit_lvalue *args = + gcc_jit_param_as_lvalue (gcc_jit_function_get_param (comp.func, 1)); + + gcc_jit_rvalue *list_args[] = + { gcc_jit_context_new_binary_op (comp.ctxt, + NULL, + GCC_JIT_BINARY_OP_MINUS, + comp.ptrdiff_type, + gcc_jit_lvalue_as_rvalue (nargs), + n), + gcc_jit_lvalue_as_rvalue (args) }; + + res = emit_call ("Flist", comp.lisp_obj_type, 2, + list_args); + + gcc_jit_block_add_assignment (comp.block, + NULL, + comp.frame[XFIXNUM (arg0)], + res); + } + else if (EQ (op, Qinc_args)) + { + /* + Limple: (inc-args) + C: ++args; + */ + gcc_jit_lvalue *args = + gcc_jit_param_as_lvalue (gcc_jit_function_get_param (comp.func, 1)); + + gcc_jit_block_add_assignment (comp.block, + NULL, + args, + emit_ptr_arithmetic ( + gcc_jit_lvalue_as_rvalue (args), + comp.lisp_obj_ptr_type, + sizeof (Lisp_Object), + comp.one)); } else if (EQ (op, Qsetimm)) { @@ -2456,11 +2476,14 @@ syms_of_comp (void) DEFSYM (Qcallref, "callref"); DEFSYM (Qncall, "ncall"); DEFSYM (Qsetpar, "setpar"); - DEFSYM (Qncall_prolog, "ncall-prolog"); DEFSYM (Qsetimm, "setimm"); DEFSYM (Qreturn, "return"); DEFSYM (Qcomp_mvar, "comp-mvar"); DEFSYM (Qcond_jump, "cond-jump"); + DEFSYM (Qset_args_to_local, "set-args-to-local"); + DEFSYM (Qset_rest_args_to_local, "set-rest-args-to-local"); + DEFSYM (Qinc_args, "inc-args"); + DEFSYM (Qcond_jump_narg_leq, "cond-jump-narg-leq"); DEFSYM (Qpush_handler, "push-handler"); DEFSYM (Qpop_handler, "pop-handler"); DEFSYM (Qcondition_case, "condition-case"); commit 29e17e08b395db8e08e4c91a543750f8021376e8 Author: Andrea Corallo Date: Sun Aug 11 16:44:12 2019 +0200 add comp-emit-narg-prologue diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 3ce3598382..0a8ab551eb 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -701,6 +701,29 @@ the annotation emission." (comp-stack-adjust (- arg)) (comp-copy-slot (+ arg (comp-sp))))))) +(defun comp-emit-narg-prologue (args-min non-rest) + "Emit the prologue for a narg function." + (cl-loop for i below args-min + do (progn + (comp-emit `(set-args-to-local ,i)) + (comp-emit '(inc-args)))) + (cl-loop for i from args-min below non-rest + for bb = (intern (format "entry_%s" i)) + for fallback = (intern (format "entry_fallback_%s" i)) + do (progn + (comp-emit `(cond-jump-narg-leq ,i ,bb ,fallback)) + (comp-mark-block-closed) + (comp-emit-block bb) + (comp-emit `(set-args-to-local ,i)) + (comp-emit '(inc-args))) + finally (comp-emit-jump 'entry_rest_args)) + (cl-loop for i from args-min below non-rest + do (comp-with-sp i + (comp-emit-block (intern (format "entry_fallback_%s" i))) + (comp-emit-set-const nil))) + (comp-emit-block 'entry_rest_args) + (comp-emit `(set-rest-args-to-local ,non-rest))) + (defun comp-limplify (func) "Given FUNC compute its LIMPLE ir." (let* ((frame-size (comp-func-frame-size func)) @@ -720,7 +743,7 @@ the annotation emission." do (cl-incf (comp-sp)) do (comp-emit `(setpar ,(comp-slot) ,i))) (let ((nonrest (comp-nargs-nonrest args))) - (comp-emit `(ncall-prolog ,nonrest)) + (comp-emit-narg-prologue args-min nonrest) (cl-incf (comp-sp) (1+ nonrest)))) ;; Body (comp-emit-block 'bb_1) commit 0c33a8ff4bd20fcb5f2d4d2a27907c77804f4e42 Author: Andrea Corallo Date: Sun Aug 11 15:04:38 2019 +0200 fix &optional args diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index a35fbd0fec..3ce3598382 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -708,18 +708,20 @@ the annotation emission." (comp-pass (make-comp-limplify :sp -1 :frame (comp-new-frame frame-size))) - (args-min (comp-args-gen-min (comp-func-args func))) + (args (comp-func-args func)) + (args-min (comp-args-gen-min args)) (comp-block ())) ;; Prologue (comp-emit-block 'entry) (comp-emit-annotation (concat "Lisp function: " (symbol-name (comp-func-symbol-name func)))) - (if (comp-args-p (comp-func-args func)) - (cl-loop for i below (comp-args-max (comp-func-args func)) + (if (comp-args-p args) + (cl-loop for i below (comp-args-max args) do (cl-incf (comp-sp)) do (comp-emit `(setpar ,(comp-slot) ,i))) - (comp-emit `(ncall-prolog ,args-min)) - (cl-incf (comp-sp) (1+ args-min))) + (let ((nonrest (comp-nargs-nonrest args))) + (comp-emit `(ncall-prolog ,nonrest)) + (cl-incf (comp-sp) (1+ nonrest)))) ;; Body (comp-emit-block 'bb_1) (mapc #'comp-limplify-lap-inst (comp-func-lap func)) commit b6e7df0926b1a569a582b0d3ff0da0c27ad368bd Author: Andrea Corallo Date: Sun Aug 11 14:54:13 2019 +0200 rework args structures diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 9bf60d1f3c..a35fbd0fec 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -76,15 +76,20 @@ finally return h) "Hash table lap-op -> stack adjustment.")) -(cl-defstruct comp-args +(cl-defstruct comp-args-gen (min nil :type number - :documentation "Minimum number of arguments allowed.") - (max nil + :documentation "Minimum number of arguments allowed.")) + +(cl-defstruct (comp-args (:include comp-args-gen)) + (max nil :type number :documentation "Maximum number of arguments allowed. -To be used when ncall-conv is nil.") - (ncall-conv nil :type boolean - :documentation "If t the signature is: -(ptrdiff_t nargs, Lisp_Object *args).")) +To be used when ncall-conv is nil.")) + +(cl-defstruct (comp-nargs (:include comp-args-gen)) + "Describe args when the functin signature is of kind: +(ptrdiff_t nargs, Lisp_Object *args)." + (nonrest nil :type number + :documentation "Number of non rest arguments.")) (cl-defstruct (comp-block (:copier nil)) "A basic block." @@ -109,7 +114,7 @@ into it.") :documentation "Byte compiled version.") (lap () :type list :documentation "Lap assembly representation.") - (args nil :type 'comp-args) + (args nil :type 'comp-args-gen) (frame-size nil :type 'number) (blocks (make-hash-table) :type 'hash-table :documentation "Key is the basic block symbol value is a comp-block @@ -203,8 +208,8 @@ BODY is evaluate only if `comp-debug' is non nil." (< nonrest 9)) ;; SUBR_MAX_ARGS (make-comp-args :min mandatory :max nonrest) - (make-comp-args :min mandatory - :ncall-conv t)))) + (make-comp-nargs :min mandatory + :nonrest nonrest)))) (defun comp-spill-lap (func) "Byte compile and spill the LAP rapresentation for FUNC." @@ -703,13 +708,13 @@ the annotation emission." (comp-pass (make-comp-limplify :sp -1 :frame (comp-new-frame frame-size))) - (args-min (comp-args-min (comp-func-args func))) + (args-min (comp-args-gen-min (comp-func-args func))) (comp-block ())) ;; Prologue (comp-emit-block 'entry) (comp-emit-annotation (concat "Lisp function: " (symbol-name (comp-func-symbol-name func)))) - (if (not (comp-args-ncall-conv (comp-func-args func))) + (if (comp-args-p (comp-func-args func)) (cl-loop for i below (comp-args-max (comp-func-args func)) do (cl-incf (comp-sp)) do (comp-emit `(setpar ,(comp-slot) ,i))) diff --git a/src/comp.c b/src/comp.c index a4793a36ad..881a78b3d7 100644 --- a/src/comp.c +++ b/src/comp.c @@ -2247,8 +2247,7 @@ DEFUN ("comp-add-func-to-ctxt", Fcomp_add_func_to_ctxt, Scomp_add_func_to_ctxt, char *c_name = (char *) SDATA (FUNCALL1 (comp-func-c-func-name, func)); Lisp_Object args = FUNCALL1 (comp-func-args, func); EMACS_INT frame_size = XFIXNUM (FUNCALL1 (comp-func-frame-size, func)); - /* EMACS_INT min_args = XFIXNUM (FUNCALL1 (comp-args-min, args)); */ - bool ncall = !NILP (FUNCALL1 (comp-args-ncall-conv, args)); + bool ncall = (FUNCALL1 (comp-nargs-p, args)); if (!ncall) { @@ -2373,8 +2372,8 @@ DEFUN ("comp-compile-and-load-ctxt", Fcomp_compile_and_load_ctxt, x->s.header.size = PVEC_SUBR << PSEUDOVECTOR_AREA_BITS; x->s.function.a0 = gcc_jit_result_get_code(gcc_res, c_name); eassert (x->s.function.a0); - x->s.min_args = XFIXNUM (FUNCALL1 (comp-args-min, args)); - if (NILP (FUNCALL1 (comp-args-ncall-conv, args))) + x->s.min_args = XFIXNUM (FUNCALL1 (comp-args-gen-min, args)); + if (FUNCALL1 (comp-args-p, args)) x->s.max_args = XFIXNUM (FUNCALL1 (comp-args-max, args)); else x->s.max_args = MANY; commit bb8f8f5cfa0f66729c6c6a333bee5bd4ba16c24c Author: Andrea Corallo Date: Sun Aug 11 14:41:35 2019 +0200 mark todos diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 3789a51774..9bf60d1f3c 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -519,7 +519,7 @@ the annotation emission." (comp-emit `(call set_internal ,(make-comp-mvar :constant arg) ,(comp-slot)))) - (byte-varbind + (byte-varbind ;; Verify (comp-emit `(call specbind ,(make-comp-mvar :constant arg) ,(comp-slot-next)))) @@ -618,7 +618,7 @@ the annotation emission." (byte-widen (comp-emit-set-call '(call Fwiden))) (byte-end-of-line auto) - (byte-constant2) + (byte-constant2) ;; TODO (byte-goto (comp-emit-jump (comp-lap-to-limple-bb (cl-third insn)))) (byte-goto-if-nil @@ -685,7 +685,7 @@ the annotation emission." (byte-stack-set (comp-with-sp (1+ (comp-sp)) (comp-copy-slot (comp-sp) (- (comp-sp) arg)))) - (byte-stack-set2) + (byte-stack-set2) ;; TODO (byte-discardN (comp-stack-adjust (- arg))) (byte-switch commit 7dc99d5d51fcadafcd7e38f169ef8b353db61e81 Author: Andrea Corallo Date: Sun Aug 11 14:10:57 2019 +0200 add save-restriction support diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 357085ee47..3789a51774 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -642,14 +642,15 @@ the annotation emission." (byte-save-excursion (comp-emit '(call record_unwind_protect_excursion))) (byte-save-window-excursion-OBSOLETE) - (byte-save-restriction) - (byte-catch) + (byte-save-restriction + '(call helper-save-restriction)) + (byte-catch) ;; Obsolete (byte-unwind-protect (comp-emit `(call helper_unwind_protect ,(comp-slot-next)))) - (byte-condition-case) + (byte-condition-case) ;; Obsolete (byte-temp-output-buffer-setup-OBSOLETE) (byte-temp-output-buffer-show-OBSOLETE) - (byte-unbind-all) + (byte-unbind-all) ;; Obsolete (byte-set-marker auto) (byte-match-beginning auto) (byte-match-end auto) diff --git a/src/comp.c b/src/comp.c index 90fa5ccdfa..a4793a36ad 100644 --- a/src/comp.c +++ b/src/comp.c @@ -165,6 +165,8 @@ Lisp_Object helper_unbind_n (Lisp_Object n); bool helper_PSEUDOVECTOR_TYPEP_XUNTAG (const union vectorlike_header *a, enum pvec_type code); +void helper_emit_save_restriction (void); + static char * ATTRIBUTE_FORMAT_PRINTF (1, 2) format_string (const char *format, ...) @@ -2075,6 +2077,8 @@ DEFUN ("comp-init-ctxt", Fcomp_init_ctxt, Scomp_init_ctxt, emit_simple_limple_call_lisp_ret); register_emitter (Qrecord_unwind_protect_excursion, emit_simple_limple_call_void_ret); + register_emitter (Qhelper_save_restriction, + emit_simple_limple_call_void_ret); } comp.ctxt = gcc_jit_context_acquire(); @@ -2389,6 +2393,8 @@ DEFUN ("comp-compile-and-load-ctxt", Fcomp_compile_and_load_ctxt, /******************************************************************************/ /* Helper functions called from the runtime. */ /* These can't be statics till shared mechanism is used to solve relocations. */ +/* Note: this are all potentially definable directly to gcc and are here just */ +/* for lazyness. Change this if a performance impact is measured. */ /******************************************************************************/ Lisp_Object @@ -2402,7 +2408,8 @@ helper_save_window_excursion (Lisp_Object v1) return v1; } -void helper_unwind_protect (Lisp_Object handler) +void +helper_unwind_protect (Lisp_Object handler) { /* Support for a function here is new in 24.4. */ record_unwind_protect (FUNCTIONP (handler) ? bcall0 : prog_ignore, @@ -2432,6 +2439,14 @@ helper_PSEUDOVECTOR_TYPEP_XUNTAG (const union vectorlike_header *a, code); } +void +helper_emit_save_restriction (void) +{ + record_unwind_protect (save_restriction_restore, + save_restriction_save ()); +} + + void syms_of_comp (void) { @@ -2457,6 +2472,7 @@ syms_of_comp (void) DEFSYM (Qrecord_unwind_protect_excursion, "record_unwind_protect_excursion"); DEFSYM (Qhelper_unbind_n, "helper_unbind_n"); DEFSYM (Qhelper_unwind_protect, "helper_unwind_protect"); + DEFSYM (Qhelper_save_restriction, "helper_save_restriction") defsubr (&Scomp_init_ctxt); defsubr (&Scomp_release_ctxt); commit bdadeff503d1796758a498dee218751520bb0cf8 Author: Andrea Corallo Date: Sun Aug 11 12:37:21 2019 +0200 add narrow-to-region + widen support diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 6fa098e0eb..357085ee47 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -611,8 +611,12 @@ the annotation emission." (byte-char-syntax auto) (byte-buffer-substring auto) (byte-delete-region auto) - (byte-narrow-to-region) - (byte-widen) + (byte-narrow-to-region + (comp-emit-set-call `(call Fnarrow_to_region + ,(comp-slot) + ,(comp-slot-next)))) + (byte-widen + (comp-emit-set-call '(call Fwiden))) (byte-end-of-line auto) (byte-constant2) (byte-goto commit 128cc4a2f401e96936e9e5791e65fbdc35ace6b2 Author: Andrea Corallo Date: Sun Aug 11 12:24:15 2019 +0200 add record_unwind_protect_excursion support diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 29d1625009..6fa098e0eb 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -635,7 +635,8 @@ the annotation emission." (byte-discard 'pass) (byte-dup (comp-copy-slot (1- (comp-sp)))) - (byte-save-excursion) + (byte-save-excursion + (comp-emit '(call record_unwind_protect_excursion))) (byte-save-window-excursion-OBSOLETE) (byte-save-restriction) (byte-catch) diff --git a/src/comp.c b/src/comp.c index 7f1219780c..90fa5ccdfa 100644 --- a/src/comp.c +++ b/src/comp.c @@ -2073,6 +2073,8 @@ DEFUN ("comp-init-ctxt", Fcomp_init_ctxt, Scomp_init_ctxt, emit_simple_limple_call_void_ret); register_emitter (Qrecord_unwind_current_buffer, emit_simple_limple_call_lisp_ret); + register_emitter (Qrecord_unwind_protect_excursion, + emit_simple_limple_call_void_ret); } comp.ctxt = gcc_jit_context_acquire(); @@ -2452,6 +2454,7 @@ syms_of_comp (void) DEFSYM (Qentry, "entry"); DEFSYM (Qset_internal, "set_internal"); DEFSYM (Qrecord_unwind_current_buffer, "record_unwind_current_buffer"); + DEFSYM (Qrecord_unwind_protect_excursion, "record_unwind_protect_excursion"); DEFSYM (Qhelper_unbind_n, "helper_unbind_n"); DEFSYM (Qhelper_unwind_protect, "helper_unwind_protect"); commit 3e18100038a0514b1ea6bee01a141f1477fdfbf6 Author: Andrea Corallo Date: Sun Aug 11 11:59:31 2019 +0200 implement log-buffer diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 79f987bd4c..29d1625009 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -35,7 +35,13 @@ "Emacs Lisp native compiler." :group 'lisp) -(defconst comp-debug t) +(defcustom comp-debug t + "Log compilation process." + :type 'boolean + :group 'comp) + +(defconst native-compile-log-buffer "*Native-compile-Log*" + "Name of the native-compiler's log buffer.") ;; FIXME these has to be removed (defvar comp-speed 2) @@ -137,14 +143,35 @@ LIMPLE basic block.") (block-name nil :type 'symbol :documentation "Current basic block name.")) -(defun comp-pretty-print-func (func) - "Pretty print function FUNC in the current buffer." - (insert (format "\n\n Function: %s" (comp-func-symbol-name func))) - (cl-loop for block-name being each hash-keys of (comp-func-blocks func) - using (hash-value bb) - do (progn - (insert (concat "\n<" (symbol-name block-name) ">")) - (cl-prettyprint (comp-block-insns bb))))) +(defmacro comp-within-log-buff (&rest body) + "Execute BODY while at the end the log-buffer. +BODY is evaluate only if `comp-debug' is non nil." + (declare (debug (form body)) + (indent defun)) + `(when comp-debug + (with-current-buffer (get-buffer-create native-compile-log-buffer) + (setq buffer-read-only t) + (let ((inhibit-read-only t)) + (goto-char (point-max)) + ,@body)))) + +(defun comp-log (string) + "Log a STRING into the log-buffer." + (comp-within-log-buff + (cond (noninteractive + (message " %s" string)) + (t + (insert (format "%s\n" string)))))) + +(defun comp-log-func (func) + "Pretty print function FUNC in the log-buffer." + (comp-within-log-buff + (insert (format "\n\n Function: %s" (comp-func-symbol-name func))) + (cl-loop for block-name being each hash-keys of (comp-func-blocks func) + using (hash-value bb) + do (progn + (insert (concat "\n<" (symbol-name block-name) ">")) + (cl-prettyprint (comp-block-insns bb)))))) ;;; spill-lap pass specific code. @@ -184,7 +211,7 @@ LIMPLE basic block.") (let (byte-compile-lap-output) (setf (comp-func-byte-func func) (byte-compile (comp-func-symbol-name func))) - (when comp-debug + (comp-within-log-buff (cl-prettyprint byte-compile-lap-output)) (let ((lambda-list (aref (comp-func-byte-func func) 0))) (if (fixnump lambda-list) @@ -689,8 +716,7 @@ the annotation emission." (cl-loop for bb being the hash-value in (comp-func-blocks func) do (setf (comp-block-insns bb) (reverse (comp-block-insns bb)))) - (when comp-debug - (comp-pretty-print-func func)) + (comp-log-func func) func)) commit 5992502ca42263855e327239eeb7f51b59a2703d Author: Andrea Corallo Date: Sun Aug 11 10:19:51 2019 +0200 add a test about buffer manipulation diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index e959e26522..1f15a0bd8b 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -453,6 +453,14 @@ (should (= (comp-test-apply #'comp-tests-cons-cdr-f 3) 3))) +(ert-deftest comp-tests-buffer () + (defun comp-tests-buff0-f () + (with-temp-buffer + (insert "foo") + (buffer-string))) + + (should (string= (comp-test-apply #'comp-tests-buff0-f) "foo"))) + ;;;;;;;;;;;;;;;;;;;; ;; Tromey's tests ;; ;;;;;;;;;;;;;;;;;;;; commit f63e1740edac418c2ab88d72e1ee56cecfec038a Author: Andrea Corallo Date: Sun Aug 11 10:15:46 2019 +0200 fix bug for not blanking func_hash after context release diff --git a/src/comp.c b/src/comp.c index 42186e7ea5..7f1219780c 100644 --- a/src/comp.c +++ b/src/comp.c @@ -2183,8 +2183,11 @@ DEFUN ("comp-init-ctxt", Fcomp_init_ctxt, Scomp_init_ctxt, sizeof (void *), false); - if (NILP (comp.func_hash)) - comp.func_hash = CALLN (Fmake_hash_table, QCtest, Qequal); + /* + Always reinitialize this cause old function definitions are garbage collected + by libgccjit when the ctxt is released. + */ + comp.func_hash = CALLN (Fmake_hash_table, QCtest, Qequal); /* Define data structures. */ commit 5dda07d22c8d974b31e196a802414c267fac5cc9 Author: Andrea Corallo Date: Sun Aug 11 10:14:57 2019 +0200 dipatcher support for helper_unwind_protect record_unwind_current_buffer diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 04668b3ed5..79f987bd4c 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -613,7 +613,7 @@ the annotation emission." (byte-save-restriction) (byte-catch) (byte-unwind-protect - (comp-emit '(call helper_unwind_protect))) + (comp-emit `(call helper_unwind_protect ,(comp-slot-next)))) (byte-condition-case) (byte-temp-output-buffer-setup-OBSOLETE) (byte-temp-output-buffer-show-OBSOLETE) diff --git a/src/comp.c b/src/comp.c index e101666cb6..42186e7ea5 100644 --- a/src/comp.c +++ b/src/comp.c @@ -246,7 +246,7 @@ declare_block (Lisp_Object block_name) } static void -register_dispatch (Lisp_Object key, void *func) +register_emitter (Lisp_Object key, void *func) { Lisp_Object value = make_mint_ptr (func); Fputhash (key, value, comp.emitter_dispatcher); @@ -1082,14 +1082,8 @@ emit_limple_ncall_prolog (EMACS_UINT n) /* This is for a regular function with arguments as m-var. */ static gcc_jit_rvalue * -emit_simple_limple_call (Lisp_Object args) +emit_simple_limple_call (Lisp_Object args, gcc_jit_type *ret_type) { - /* - Ex: (call Fcar #s(comp-mvar 4 0 nil nil nil)) - - Ex: (call Fcons #s(comp-mvar 3 0 t 1 nil) - #s(comp-mvar 4 nil t nil nil)) - */ int i = 0; char *calle = (char *) SDATA (SYMBOL_NAME (FIRST (args))); args = XCDR (args); @@ -1098,7 +1092,25 @@ emit_simple_limple_call (Lisp_Object args) FOR_EACH_TAIL (args) gcc_args[i++] = emit_mvar_val (XCAR (args)); - return emit_call (calle, comp.lisp_obj_type, nargs, gcc_args); + return emit_call (calle, ret_type, nargs, gcc_args); +} + +static gcc_jit_rvalue * +emit_simple_limple_call_lisp_ret (Lisp_Object args) +{ + /* + Ex: (call Fcar #s(comp-mvar 4 0 nil nil nil)) + + Ex: (call Fcons #s(comp-mvar 3 0 t 1 nil) + #s(comp-mvar 4 nil t nil nil)) + */ + return emit_simple_limple_call (args, comp.lisp_obj_type); +} + +static gcc_jit_rvalue * +emit_simple_limple_call_void_ret (Lisp_Object args) +{ + return emit_simple_limple_call (args, comp.void_type); } /* Entry point to dispatch emitting (call fun ...). */ @@ -1117,13 +1129,9 @@ emit_limple_call (Lisp_Object args) } else if (calle[0] == 'F') { - return emit_simple_limple_call (args); - } - else if (!strcmp (calle, "record_unwind_current_buffer") || - !strcmp (calle, "helper_unwind_protect")) - { - return emit_call (calle, comp.void_type, 0, NULL); + return emit_simple_limple_call_lisp_ret (args); } + error ("LIMPLE call is inconsistent"); } @@ -2059,8 +2067,12 @@ DEFUN ("comp-init-ctxt", Fcomp_init_ctxt, Scomp_init_ctxt, { /* Move this into syms_of_comp the day will be dumpable. */ comp.emitter_dispatcher = CALLN (Fmake_hash_table); - register_dispatch (Qset_internal, emit_set_internal); - register_dispatch (Qhelper_unbind_n, emit_simple_limple_call); + register_emitter (Qset_internal, emit_set_internal); + register_emitter (Qhelper_unbind_n, emit_simple_limple_call_lisp_ret); + register_emitter (Qhelper_unwind_protect, + emit_simple_limple_call_void_ret); + register_emitter (Qrecord_unwind_current_buffer, + emit_simple_limple_call_lisp_ret); } comp.ctxt = gcc_jit_context_acquire(); @@ -2436,7 +2448,9 @@ syms_of_comp (void) DEFSYM (Qcatcher, "catcher"); DEFSYM (Qentry, "entry"); DEFSYM (Qset_internal, "set_internal"); + DEFSYM (Qrecord_unwind_current_buffer, "record_unwind_current_buffer"); DEFSYM (Qhelper_unbind_n, "helper_unbind_n"); + DEFSYM (Qhelper_unwind_protect, "helper_unwind_protect"); defsubr (&Scomp_init_ctxt); defsubr (&Scomp_release_ctxt); commit 9901f47ef77e777ebe0183624024527ce691256d Author: Andrea Corallo Date: Sun Aug 11 09:34:30 2019 +0200 some fixes to unbind_n diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 7fa723fc88..04668b3ed5 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -500,9 +500,8 @@ the annotation emission." (comp-stack-adjust (- arg)) (comp-emit-set-call `(callref Ffuncall ,(1+ arg) ,(comp-sp)))) (byte-unbind - (comp-emit `(call unbind_to - ,(make-comp-mvar :constant arg) - ,(make-comp-mvar :constant nil)))) + (comp-emit `(call helper_unbind_n + ,(make-comp-mvar :constant arg)))) (byte-pophandler (comp-emit '(pop-handler))) (byte-pushconditioncase diff --git a/src/comp.c b/src/comp.c index 347a3b351e..e101666cb6 100644 --- a/src/comp.c +++ b/src/comp.c @@ -160,7 +160,7 @@ void helper_unwind_protect (Lisp_Object handler); Lisp_Object helper_temp_output_buffer_setup (Lisp_Object x); -Lisp_Object helper_unbind_n (int val); +Lisp_Object helper_unbind_n (Lisp_Object n); bool helper_PSEUDOVECTOR_TYPEP_XUNTAG (const union vectorlike_header *a, enum pvec_type code); @@ -1101,15 +1101,14 @@ emit_simple_limple_call (Lisp_Object args) return emit_call (calle, comp.lisp_obj_type, nargs, gcc_args); } -/* Entry point to dispatch emission of (call fun ...). */ +/* Entry point to dispatch emitting (call fun ...). */ static gcc_jit_rvalue * emit_limple_call (Lisp_Object args) { Lisp_Object calle_sym = FIRST (args); char *calle = (char *) SDATA (SYMBOL_NAME (calle_sym)); - Lisp_Object emitter = - Fgethash (calle_sym, comp.emitter_dispatcher, Qnil); + Lisp_Object emitter = Fgethash (calle_sym, comp.emitter_dispatcher, Qnil); if (!NILP (emitter)) { @@ -2061,7 +2060,7 @@ DEFUN ("comp-init-ctxt", Fcomp_init_ctxt, Scomp_init_ctxt, /* Move this into syms_of_comp the day will be dumpable. */ comp.emitter_dispatcher = CALLN (Fmake_hash_table); register_dispatch (Qset_internal, emit_set_internal); - register_dispatch (Qhelper_unbind_n, helper_unbind_n); + register_dispatch (Qhelper_unbind_n, emit_simple_limple_call); } comp.ctxt = gcc_jit_context_acquire(); @@ -2402,9 +2401,9 @@ helper_temp_output_buffer_setup (Lisp_Object x) } Lisp_Object -helper_unbind_n (int val) +helper_unbind_n (Lisp_Object n) { - return unbind_to (SPECPDL_INDEX () - val, Qnil); + return unbind_to (SPECPDL_INDEX () - XFIXNUM (n), Qnil); } bool commit e65d2f364cf40891d15009e9764143a45c2d164c Author: Andrea Corallo Date: Sun Aug 11 09:18:45 2019 +0200 some renaming diff --git a/src/comp.c b/src/comp.c index 08fa384654..347a3b351e 100644 --- a/src/comp.c +++ b/src/comp.c @@ -145,7 +145,7 @@ typedef struct { Lisp_Object func_blocks; /* blk_name -> gcc_block. */ Lisp_Object func_hash; /* f_name -> gcc_func. */ Lisp_Object funcs; /* List of functions defined. */ - Lisp_Object routine_dispatcher; + Lisp_Object emitter_dispatcher; } comp_t; static comp_t comp; @@ -249,7 +249,7 @@ static void register_dispatch (Lisp_Object key, void *func) { Lisp_Object value = make_mint_ptr (func); - Fputhash (key, value, comp.routine_dispatcher); + Fputhash (key, value, comp.emitter_dispatcher); } @@ -1109,7 +1109,7 @@ emit_limple_call (Lisp_Object args) Lisp_Object calle_sym = FIRST (args); char *calle = (char *) SDATA (SYMBOL_NAME (calle_sym)); Lisp_Object emitter = - Fgethash (calle_sym, comp.routine_dispatcher, Qnil); + Fgethash (calle_sym, comp.emitter_dispatcher, Qnil); if (!NILP (emitter)) { @@ -2056,10 +2056,10 @@ DEFUN ("comp-init-ctxt", Fcomp_init_ctxt, Scomp_init_ctxt, return Qnil; } - if (NILP (comp.routine_dispatcher)) + if (NILP (comp.emitter_dispatcher)) { /* Move this into syms_of_comp the day will be dumpable. */ - comp.routine_dispatcher = CALLN (Fmake_hash_table); + comp.emitter_dispatcher = CALLN (Fmake_hash_table); register_dispatch (Qset_internal, emit_set_internal); register_dispatch (Qhelper_unbind_n, helper_unbind_n); } @@ -2172,7 +2172,8 @@ DEFUN ("comp-init-ctxt", Fcomp_init_ctxt, Scomp_init_ctxt, sizeof (void *), false); - comp.func_hash = CALLN (Fmake_hash_table, QCtest, Qequal); + if (NILP (comp.func_hash)) + comp.func_hash = CALLN (Fmake_hash_table, QCtest, Qequal); /* Define data structures. */ @@ -2442,13 +2443,12 @@ syms_of_comp (void) defsubr (&Scomp_release_ctxt); defsubr (&Scomp_add_func_to_ctxt); defsubr (&Scomp_compile_and_load_ctxt); + staticpro (&comp.func_hash); - staticpro (&comp.func_blocks); comp.func_hash = Qnil; - comp.routine_dispatcher = Qnil; - - staticpro (&comp.routine_dispatcher); - comp.routine_dispatcher = Qnil; + staticpro (&comp.func_blocks); + staticpro (&comp.emitter_dispatcher); + comp.emitter_dispatcher = Qnil; DEFVAR_INT ("comp-speed", comp_speed, doc: /* From 0 to 3. */); commit b9c228438d34b15ae2804a563d4d52b5e0de62ad Author: Andrea Corallo Date: Sat Aug 10 23:20:40 2019 +0200 block hash use symbol as key diff --git a/src/comp.c b/src/comp.c index d7326ad703..08fa384654 100644 --- a/src/comp.c +++ b/src/comp.c @@ -225,11 +225,9 @@ type_to_cast_field (gcc_jit_type *type) } static gcc_jit_block * -retrive_block (Lisp_Object symbol) +retrive_block (Lisp_Object block_name) { - char *block_name = (char *) SDATA (SYMBOL_NAME (symbol)); - Lisp_Object key = make_string (block_name, strlen (block_name)); - Lisp_Object value = Fgethash (key, comp.func_blocks, Qnil); + Lisp_Object value = Fgethash (block_name, comp.func_blocks, Qnil); if (NILP (value)) error ("LIMPLE basic block inconsistency"); @@ -237,14 +235,14 @@ retrive_block (Lisp_Object symbol) } static void -declare_block (const char * block_name) +declare_block (Lisp_Object block_name) { - gcc_jit_block *block = gcc_jit_function_new_block (comp.func, block_name); - Lisp_Object key = make_string (block_name, strlen (block_name)); + char *name_str = (char *) SDATA (SYMBOL_NAME (block_name)); + gcc_jit_block *block = gcc_jit_function_new_block (comp.func, name_str); Lisp_Object value = make_mint_ptr (block); - if (!NILP (Fgethash (key, comp.func_blocks, Qnil))) + if (!NILP (Fgethash (block_name, comp.func_blocks, Qnil))) error ("LIMPLE basic block inconsistency"); - Fputhash (key, value, comp.func_blocks); + Fputhash (block_name, value, comp.func_blocks); } static void @@ -2279,19 +2277,19 @@ DEFUN ("comp-add-func-to-ctxt", Fcomp_add_func_to_ctxt, Scomp_add_func_to_ctxt, i)); comp.frame = frame; - comp.func_blocks = CALLN (Fmake_hash_table, QCtest, Qequal); + comp.func_blocks = CALLN (Fmake_hash_table); /* Pre declare all basic blocks to gcc. The "entry" block must be declared as first. */ - declare_block ("entry"); + declare_block (Qentry); Lisp_Object blocks = FUNCALL1 (comp-func-blocks, func); - Lisp_Object entry_block = Fgethash (intern ("entry"), blocks, Qnil); + Lisp_Object entry_block = Fgethash (Qentry, blocks, Qnil); struct Lisp_Hash_Table *ht = XHASH_TABLE (blocks); for (ptrdiff_t i = 0; i < ht->count; i++) { Lisp_Object block = HASH_VALUE (ht, i); if (!EQ (block, entry_block)) - declare_block ((char *) SDATA (SYMBOL_NAME (HASH_KEY (ht, i)))); + declare_block (HASH_KEY (ht, i)); } for (ptrdiff_t i = 0; i < ht->count; i++) @@ -2436,6 +2434,7 @@ syms_of_comp (void) DEFSYM (Qpop_handler, "pop-handler"); DEFSYM (Qcondition_case, "condition-case"); DEFSYM (Qcatcher, "catcher"); + DEFSYM (Qentry, "entry"); DEFSYM (Qset_internal, "set_internal"); DEFSYM (Qhelper_unbind_n, "helper_unbind_n"); commit 9273afa89034783aa26d4f5bb43cf22afce57e74 Author: Andrea Corallo Date: Sat Aug 10 22:38:03 2019 +0200 save C pointers as mint_ptr type to avoid corruption diff --git a/src/comp.c b/src/comp.c index 37264039ed..d7326ad703 100644 --- a/src/comp.c +++ b/src/comp.c @@ -233,7 +233,7 @@ retrive_block (Lisp_Object symbol) if (NILP (value)) error ("LIMPLE basic block inconsistency"); - return (gcc_jit_block *) XFIXNUMPTR (value); + return (gcc_jit_block *) xmint_pointer (value); } static void @@ -241,7 +241,7 @@ declare_block (const char * block_name) { gcc_jit_block *block = gcc_jit_function_new_block (comp.func, block_name); Lisp_Object key = make_string (block_name, strlen (block_name)); - Lisp_Object value = make_pointer_integer (XPL (block)); + Lisp_Object value = make_mint_ptr (block); if (!NILP (Fgethash (key, comp.func_blocks, Qnil))) error ("LIMPLE basic block inconsistency"); Fputhash (key, value, comp.func_blocks); @@ -302,10 +302,10 @@ emit_func_declare (const char *f_name, gcc_jit_type *ret_type, if (reusable) { Lisp_Object key = make_string (f_name, strlen (f_name)); - Lisp_Object value = make_pointer_integer (XPL (func)); + Lisp_Object value = make_mint_ptr (func); /* Don't want to declare the same function two times. */ - if (!NILP (Fgethash (key, comp.func_hash, Qnil))) - eassert (false); + eassert (NILP (Fgethash (key, comp.func_hash, Qnil))); + Fputhash (key, value, comp.func_hash); } @@ -326,7 +326,7 @@ emit_call (const char *f_name, gcc_jit_type *ret_type, unsigned nargs, value = Fgethash (key, comp.func_hash, Qnil); eassert (!NILP (value)); } - gcc_jit_function *func = (gcc_jit_function *) XFIXNUMPTR (value); + gcc_jit_function *func = (gcc_jit_function *) xmint_pointer (value); return gcc_jit_context_new_call(comp.ctxt, NULL, commit df59970cc41cee834f2432a18a098ec7de16f7ae Author: Andrea Corallo Date: Sat Aug 10 22:13:45 2019 +0200 improve routine dispatcher diff --git a/src/comp.c b/src/comp.c index 3a9fbe733d..37264039ed 100644 --- a/src/comp.c +++ b/src/comp.c @@ -152,6 +152,20 @@ static comp_t comp; FILE *logfile = NULL; + + +Lisp_Object helper_save_window_excursion (Lisp_Object v1); + +void helper_unwind_protect (Lisp_Object handler); + +Lisp_Object helper_temp_output_buffer_setup (Lisp_Object x); + +Lisp_Object helper_unbind_n (int val); + +bool helper_PSEUDOVECTOR_TYPEP_XUNTAG (const union vectorlike_header *a, + enum pvec_type code); + + static char * ATTRIBUTE_FORMAT_PRINTF (1, 2) format_string (const char *format, ...) { @@ -234,10 +248,9 @@ declare_block (const char * block_name) } static void -register_dispatch (const char *name, void *func) +register_dispatch (Lisp_Object key, void *func) { - Lisp_Object key = make_string (name, strlen (name)); - Lisp_Object value = make_pointer_integer (XPL (func)); + Lisp_Object value = make_mint_ptr (func); Fputhash (key, value, comp.routine_dispatcher); } @@ -1098,11 +1111,11 @@ emit_limple_call (Lisp_Object args) Lisp_Object calle_sym = FIRST (args); char *calle = (char *) SDATA (SYMBOL_NAME (calle_sym)); Lisp_Object emitter = - Fgethash (SYMBOL_NAME (calle_sym), comp.routine_dispatcher, Qnil); + Fgethash (calle_sym, comp.routine_dispatcher, Qnil); if (!NILP (emitter)) { - gcc_jit_rvalue * (* emitter_ptr) (Lisp_Object) = XFIXNUMPTR (emitter); + gcc_jit_rvalue * (* emitter_ptr) (Lisp_Object) = xmint_pointer (emitter); return emitter_ptr (args); } else if (calle[0] == 'F') @@ -2045,6 +2058,14 @@ DEFUN ("comp-init-ctxt", Fcomp_init_ctxt, Scomp_init_ctxt, return Qnil; } + if (NILP (comp.routine_dispatcher)) + { + /* Move this into syms_of_comp the day will be dumpable. */ + comp.routine_dispatcher = CALLN (Fmake_hash_table); + register_dispatch (Qset_internal, emit_set_internal); + register_dispatch (Qhelper_unbind_n, helper_unbind_n); + } + comp.ctxt = gcc_jit_context_acquire(); comp.funcs = Qnil; @@ -2349,64 +2370,12 @@ DEFUN ("comp-compile-and-load-ctxt", Fcomp_compile_and_load_ctxt, return Qt; } -void -syms_of_comp (void) -{ - /* Limple instruction set. */ - DEFSYM (Qcomment, "comment"); - DEFSYM (Qjump, "jump"); - DEFSYM (Qcall, "call"); - DEFSYM (Qcallref, "callref"); - DEFSYM (Qncall, "ncall"); - DEFSYM (Qsetpar, "setpar"); - DEFSYM (Qncall_prolog, "ncall-prolog"); - DEFSYM (Qsetimm, "setimm"); - DEFSYM (Qreturn, "return"); - DEFSYM (Qcomp_mvar, "comp-mvar"); - DEFSYM (Qcond_jump, "cond-jump"); - DEFSYM (Qpush_handler, "push-handler"); - DEFSYM (Qpop_handler, "pop-handler"); - DEFSYM (Qcondition_case, "condition-case"); - DEFSYM (Qcatcher, "catcher"); - - defsubr (&Scomp_init_ctxt); - defsubr (&Scomp_release_ctxt); - defsubr (&Scomp_add_func_to_ctxt); - defsubr (&Scomp_compile_and_load_ctxt); - comp.func_hash = Qnil; - comp.routine_dispatcher = Qnil; - staticpro (&comp.func_hash); - staticpro (&comp.func_blocks); - - comp.routine_dispatcher = CALLN (Fmake_hash_table, QCtest, Qequal); - register_dispatch ("set_internal", emit_set_internal); - register_dispatch ("helper_unbind_n", emit_simple_limple_call); - staticpro (&comp.routine_dispatcher); - - DEFVAR_INT ("comp-speed", comp_speed, - doc: /* From 0 to 3. */); - comp_speed = DEFAULT_SPEED; - -} - /******************************************************************************/ /* Helper functions called from the runtime. */ /* These can't be statics till shared mechanism is used to solve relocations. */ /******************************************************************************/ -/* TODO: cleanup */ - -Lisp_Object helper_save_window_excursion (Lisp_Object v1); - -void helper_unwind_protect (Lisp_Object handler); - -Lisp_Object helper_temp_output_buffer_setup (Lisp_Object x); - -Lisp_Object helper_unbind_n (int val); - -bool helper_PSEUDOVECTOR_TYPEP_XUNTAG (const union vectorlike_header *a, - enum pvec_type code); Lisp_Object helper_save_window_excursion (Lisp_Object v1) { @@ -2448,4 +2417,43 @@ helper_PSEUDOVECTOR_TYPEP_XUNTAG (const union vectorlike_header *a, code); } +void +syms_of_comp (void) +{ + /* Limple instruction set. */ + DEFSYM (Qcomment, "comment"); + DEFSYM (Qjump, "jump"); + DEFSYM (Qcall, "call"); + DEFSYM (Qcallref, "callref"); + DEFSYM (Qncall, "ncall"); + DEFSYM (Qsetpar, "setpar"); + DEFSYM (Qncall_prolog, "ncall-prolog"); + DEFSYM (Qsetimm, "setimm"); + DEFSYM (Qreturn, "return"); + DEFSYM (Qcomp_mvar, "comp-mvar"); + DEFSYM (Qcond_jump, "cond-jump"); + DEFSYM (Qpush_handler, "push-handler"); + DEFSYM (Qpop_handler, "pop-handler"); + DEFSYM (Qcondition_case, "condition-case"); + DEFSYM (Qcatcher, "catcher"); + DEFSYM (Qset_internal, "set_internal"); + DEFSYM (Qhelper_unbind_n, "helper_unbind_n"); + + defsubr (&Scomp_init_ctxt); + defsubr (&Scomp_release_ctxt); + defsubr (&Scomp_add_func_to_ctxt); + defsubr (&Scomp_compile_and_load_ctxt); + staticpro (&comp.func_hash); + staticpro (&comp.func_blocks); + comp.func_hash = Qnil; + comp.routine_dispatcher = Qnil; + + staticpro (&comp.routine_dispatcher); + comp.routine_dispatcher = Qnil; + + DEFVAR_INT ("comp-speed", comp_speed, + doc: /* From 0 to 3. */); + comp_speed = DEFAULT_SPEED; +} + #endif /* HAVE_LIBGCCJIT */ commit a42d67628942244b0cb90276c4e0ec77e967c0bc Author: Andrea Corallo Date: Sat Aug 10 20:21:43 2019 +0200 change emit_limple_call_ref arg convention diff --git a/src/comp.c b/src/comp.c index 6552ea91c1..3a9fbe733d 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1097,7 +1097,8 @@ emit_limple_call (Lisp_Object args) { Lisp_Object calle_sym = FIRST (args); char *calle = (char *) SDATA (SYMBOL_NAME (calle_sym)); - Lisp_Object emitter = Fgethash (SYMBOL_NAME (calle_sym), comp.routine_dispatcher, Qnil); + Lisp_Object emitter = + Fgethash (SYMBOL_NAME (calle_sym), comp.routine_dispatcher, Qnil); if (!NILP (emitter)) { @@ -1117,13 +1118,13 @@ emit_limple_call (Lisp_Object args) } static gcc_jit_rvalue * -emit_limple_call_ref (Lisp_Object arg1) +emit_limple_call_ref (Lisp_Object args) { /* Ex: (callref Fplus 2 0). */ - char *calle = (char *) SDATA (SYMBOL_NAME (SECOND (arg1))); - EMACS_UINT nargs = XFIXNUM (THIRD (arg1)); - EMACS_UINT base_ptr = XFIXNUM (FORTH (arg1)); + char *calle = (char *) SDATA (SYMBOL_NAME (FIRST (args))); + EMACS_UINT nargs = XFIXNUM (SECOND (args)); + EMACS_UINT base_ptr = XFIXNUM (THIRD (args)); gcc_jit_rvalue *gcc_args[2] = { gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.ptrdiff_type, @@ -1285,7 +1286,7 @@ emit_limple_insn (Lisp_Object insn) else if (EQ (FIRST (arg1), Qcall)) res = emit_limple_call (XCDR (arg1)); else if (EQ (FIRST (arg1), Qcallref)) - res = emit_limple_call_ref (arg1); + res = emit_limple_call_ref (XCDR (arg1)); else error ("LIMPLE inconsistent arg1 for op ="); eassert (res); commit 26da67d10b93e2997679e27b56a072e4767102c2 Author: Andrea Corallo Date: Sat Aug 10 18:17:05 2019 +0200 add routine dispatcher diff --git a/src/comp.c b/src/comp.c index 96e9c55f44..6552ea91c1 100644 --- a/src/comp.c +++ b/src/comp.c @@ -145,6 +145,7 @@ typedef struct { Lisp_Object func_blocks; /* blk_name -> gcc_block. */ Lisp_Object func_hash; /* f_name -> gcc_func. */ Lisp_Object funcs; /* List of functions defined. */ + Lisp_Object routine_dispatcher; } comp_t; static comp_t comp; @@ -232,6 +233,15 @@ declare_block (const char * block_name) Fputhash (key, value, comp.func_blocks); } +static void +register_dispatch (const char *name, void *func) +{ + Lisp_Object key = make_string (name, strlen (name)); + Lisp_Object value = make_pointer_integer (XPL (func)); + Fputhash (key, value, comp.routine_dispatcher); +} + + INLINE static void emit_comment (const char *str) { @@ -241,22 +251,6 @@ emit_comment (const char *str) str); } - -/* Assignments to the meta-stack slots should be emitted usign this to always */ -/* reset annotation fields. */ - -/* static void */ -/* emit_assign_to_stack_slot (basic_block_t *block, stack_el_t *slot, */ -/* gcc_jit_rvalue *val) */ -/* { */ -/* gcc_jit_block_add_assignment (block->gcc_bb, */ -/* NULL, */ -/* slot->gcc_lval, */ -/* val); */ -/* slot->type = -1; */ -/* slot->const_set = false; */ -/* } */ - /* Declare a function with all args being Lisp_Object and returning a Lisp_Object. */ @@ -951,7 +945,7 @@ emit_PURE_P (gcc_jit_rvalue *ptr) /*************************************/ -/* Code emittes by LIMPLE statemes. */ +/* Code emitted by LIMPLE statemes. */ /*************************************/ /* Emit an r-value from an mvar meta variable. @@ -984,6 +978,28 @@ emit_mvar_val (Lisp_Object mvar) } } +static gcc_jit_rvalue * +emit_set_internal (Lisp_Object args) +{ + /* + Ex: (call set_internal + #s(comp-mvar 7 nil t xxx nil) + #s(comp-mvar 6 1 t 3 nil)) + */ + /* TODO: Inline the most common case. */ + eassert (list_length (args) == 3); + args = XCDR (args); + int i = 0; + gcc_jit_rvalue *gcc_args[4]; + FOR_EACH_TAIL (args) + gcc_args[i++] = emit_mvar_val (XCAR (args)); + gcc_args[2] = emit_lisp_obj_from_ptr (Qnil); + gcc_args[3] = gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.int_type, + SET_INTERNAL_SET); + return emit_call ("set_internal", comp.void_type , 4, gcc_args); +} + static void emit_limple_ncall_prolog (EMACS_UINT n) { @@ -1052,46 +1068,45 @@ emit_limple_ncall_prolog (EMACS_UINT n) list_args)); } +/* This is for a regular function with arguments as m-var. */ + static gcc_jit_rvalue * -emit_limple_call (Lisp_Object arg1) +emit_simple_limple_call (Lisp_Object args) { - char *calle = (char *) SDATA (SYMBOL_NAME (SECOND (arg1))); - Lisp_Object call_args = XCDR (XCDR (arg1)); - int i = 0; + /* + Ex: (call Fcar #s(comp-mvar 4 0 nil nil nil)) - if (calle[0] == 'F') - { - /* - Ex: (call Fcar #s(comp-mvar 4 0 nil nil nil)) + Ex: (call Fcons #s(comp-mvar 3 0 t 1 nil) + #s(comp-mvar 4 nil t nil nil)) + */ + int i = 0; + char *calle = (char *) SDATA (SYMBOL_NAME (FIRST (args))); + args = XCDR (args); + ptrdiff_t nargs = list_length (args); + gcc_jit_rvalue *gcc_args[nargs]; + FOR_EACH_TAIL (args) + gcc_args[i++] = emit_mvar_val (XCAR (args)); + + return emit_call (calle, comp.lisp_obj_type, nargs, gcc_args); +} - Ex: (call Fcons #s(comp-mvar 3 0 t 1 nil) - #s(comp-mvar 4 nil t nil nil)) - */ +/* Entry point to dispatch emission of (call fun ...). */ - ptrdiff_t nargs = list_length (call_args); - gcc_jit_rvalue *gcc_args[nargs]; - FOR_EACH_TAIL (call_args) - gcc_args[i++] = emit_mvar_val (XCAR (call_args)); +static gcc_jit_rvalue * +emit_limple_call (Lisp_Object args) +{ + Lisp_Object calle_sym = FIRST (args); + char *calle = (char *) SDATA (SYMBOL_NAME (calle_sym)); + Lisp_Object emitter = Fgethash (SYMBOL_NAME (calle_sym), comp.routine_dispatcher, Qnil); - return emit_call (calle, comp.lisp_obj_type, nargs, gcc_args); + if (!NILP (emitter)) + { + gcc_jit_rvalue * (* emitter_ptr) (Lisp_Object) = XFIXNUMPTR (emitter); + return emitter_ptr (args); } - else if (!strcmp (calle, "set_internal")) + else if (calle[0] == 'F') { - /* - Ex: (call set_internal - #s(comp-mvar 7 nil t xxx nil) - #s(comp-mvar 6 1 t 3 nil)) - */ - /* TODO: Inline the most common case. */ - eassert (list_length (call_args) == 2); - gcc_jit_rvalue *gcc_args[4]; - FOR_EACH_TAIL (call_args) - gcc_args[i++] = emit_mvar_val (XCAR (call_args)); - gcc_args[2] = emit_lisp_obj_from_ptr (Qnil); - gcc_args[3] = gcc_jit_context_new_rvalue_from_int (comp.ctxt, - comp.int_type, - SET_INTERNAL_SET); - return emit_call ("set_internal", comp.void_type , 4, gcc_args); + return emit_simple_limple_call (args); } else if (!strcmp (calle, "record_unwind_current_buffer") || !strcmp (calle, "helper_unwind_protect")) @@ -1258,7 +1273,7 @@ emit_limple_insn (Lisp_Object insn) { gcc_jit_block_add_eval (comp.block, NULL, - emit_limple_call (insn)); + emit_limple_call (args)); } else if (EQ (op, Qset)) { @@ -1268,7 +1283,7 @@ emit_limple_insn (Lisp_Object insn) if (EQ (Ftype_of (arg1), Qcomp_mvar)) res = emit_mvar_val (arg1); else if (EQ (FIRST (arg1), Qcall)) - res = emit_limple_call (arg1); + res = emit_limple_call (XCDR (arg1)); else if (EQ (FIRST (arg1), Qcallref)) res = emit_limple_call_ref (arg1); else @@ -2028,6 +2043,7 @@ DEFUN ("comp-init-ctxt", Fcomp_init_ctxt, Scomp_init_ctxt, error ("Compiler context already taken."); return Qnil; } + comp.ctxt = gcc_jit_context_acquire(); comp.funcs = Qnil; @@ -2357,9 +2373,15 @@ syms_of_comp (void) defsubr (&Scomp_add_func_to_ctxt); defsubr (&Scomp_compile_and_load_ctxt); comp.func_hash = Qnil; + comp.routine_dispatcher = Qnil; staticpro (&comp.func_hash); staticpro (&comp.func_blocks); + comp.routine_dispatcher = CALLN (Fmake_hash_table, QCtest, Qequal); + register_dispatch ("set_internal", emit_set_internal); + register_dispatch ("helper_unbind_n", emit_simple_limple_call); + staticpro (&comp.routine_dispatcher); + DEFVAR_INT ("comp-speed", comp_speed, doc: /* From 0 to 3. */); comp_speed = DEFAULT_SPEED; commit e1757517c33d9c6428ecab8bc277aea14ec0c96f Author: Andrea Corallo Date: Sat Aug 10 18:16:17 2019 +0200 fix hash table weakness diff --git a/src/comp.c b/src/comp.c index 29fd9ce4f2..96e9c55f44 100644 --- a/src/comp.c +++ b/src/comp.c @@ -2136,7 +2136,7 @@ DEFUN ("comp-init-ctxt", Fcomp_init_ctxt, Scomp_init_ctxt, sizeof (void *), false); - comp.func_hash = CALLN (Fmake_hash_table, QCtest, Qequal, QCweakness, Qt); + comp.func_hash = CALLN (Fmake_hash_table, QCtest, Qequal); /* Define data structures. */ @@ -2241,7 +2241,7 @@ DEFUN ("comp-add-func-to-ctxt", Fcomp_add_func_to_ctxt, Scomp_add_func_to_ctxt, i)); comp.frame = frame; - comp.func_blocks = CALLN (Fmake_hash_table, QCtest, Qequal, QCweakness, Qt); + comp.func_blocks = CALLN (Fmake_hash_table, QCtest, Qequal); /* Pre declare all basic blocks to gcc. The "entry" block must be declared as first. */ commit 7720dceba1079151c37aa0a3117ac22dac45a119 Author: Andrea Corallo Date: Thu Aug 8 17:35:25 2019 +0200 add record_unwind_current_buffer helper_unwind_protect support diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 169a124cc1..7fa723fc88 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -573,7 +573,8 @@ the annotation emission." (byte-bobp auto) (byte-current-buffer auto) (byte-set-buffer auto) - (byte-save-current-buffer) + (byte-save-current-buffer + (comp-emit '(call record_unwind_current_buffer))) (byte-set-mark-OBSOLETE) (byte-interactive-p-OBSOLETE) (byte-forward-char auto) @@ -603,7 +604,7 @@ the annotation emission." (comp-emit-cond-jump (comp-slot-next) (make-comp-mvar :constant nil) 1 (cl-third insn) t)) (byte-return - (comp-emit (list 'return (comp-slot-next))) + (comp-emit `(return ,(comp-slot-next))) (comp-mark-block-closed)) (byte-discard 'pass) (byte-dup @@ -612,7 +613,8 @@ the annotation emission." (byte-save-window-excursion-OBSOLETE) (byte-save-restriction) (byte-catch) - (byte-unwind-protect) + (byte-unwind-protect + (comp-emit '(call helper_unwind_protect))) (byte-condition-case) (byte-temp-output-buffer-setup-OBSOLETE) (byte-temp-output-buffer-show-OBSOLETE) diff --git a/src/comp.c b/src/comp.c index 5c5551c8da..29fd9ce4f2 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1093,6 +1093,11 @@ emit_limple_call (Lisp_Object arg1) SET_INTERNAL_SET); return emit_call ("set_internal", comp.void_type , 4, gcc_args); } + else if (!strcmp (calle, "record_unwind_current_buffer") || + !strcmp (calle, "helper_unwind_protect")) + { + return emit_call (calle, comp.void_type, 0, NULL); + } error ("LIMPLE call is inconsistent"); } commit b670b2d8be07dd47274e4e771437b6c4e8649d66 Author: Andrea Corallo Date: Thu Aug 8 17:18:25 2019 +0200 pthread_sigmask instead of unblock_atimers diff --git a/src/comp.c b/src/comp.c index 54078e89bf..5c5551c8da 100644 --- a/src/comp.c +++ b/src/comp.c @@ -2322,7 +2322,7 @@ DEFUN ("comp-compile-and-load-ctxt", Fcomp_compile_and_load_ctxt, comp.funcs = XCDR (comp.funcs); } - unblock_atimers (&oldset); + pthread_sigmask (SIG_SETMASK, &oldset, 0); return Qt; } commit 39e224ba18485d7da68d13579c74afb2cc86f382 Author: Andrea Corallo Date: Thu Aug 8 10:54:39 2019 +0200 clean-up unnecessary declarations diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 9e62f88896..169a124cc1 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -695,11 +695,6 @@ the annotation emission." ;;; Entry points. -(declare-function comp-init-ctxt "comp.c") -(declare-function comp-release-ctxt "comp.c") -(declare-function comp-add-func-to-ctxt "comp.c") -(declare-function comp-compile-and-load-ctxt "comp.c") - (defun native-compile (func-symbol-name) "FUNC-SYMBOL-NAME is the function name to be compiled into native code." (if-let ((f (symbol-function func-symbol-name))) commit a5e428a638718223b0ab667382a8493a135db0ca Author: Andrea Corallo Date: Wed Aug 7 22:00:35 2019 +0200 rework tests diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 332dd3f8c0..e959e26522 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -27,19 +27,42 @@ (require 'ert) (require 'comp) +;; (require 'cl-lib) -(setq garbage-collection-messages t) +(defun comp-test-apply (func &rest args) + (unless (subrp (symbol-function func)) + (native-compile func)) + (apply func args)) + +(defun comp-mashup (&rest args) + "Mash-up ARGS and return a symbol." + (intern (apply #'concat + (mapcar (lambda (x) + (cl-etypecase x + (symbol (symbol-name x)) + (string x))) + args)))) + +;; (setq garbage-collection-messages t) (defvar comp-tests-var1 3) -(ert-deftest comp-tests-varref () +;; (defmacro comp-ert-deftest (name &rest body) +;; (declare (indent defun)) +;; `(progn +;; ,@(cl-loop for speed from 0 to 3 +;; for test-name = (comp-mashup name "-speed-" +;; (number-to-string speed)) +;; collect `(ert-deftest ,test-name () +;; (let ((comp-speed ,speed)) +;; ,body))))) + +(ert-deftest comp-tests-varref () "Testing varref." (defun comp-tests-varref-f () comp-tests-var1) - (native-compile #'comp-tests-varref-f) - - (should (= (comp-tests-varref-f) 3))) + (should (= (comp-test-apply #'comp-tests-varref-f) 3))) (ert-deftest comp-tests-list () "Testing cons car cdr." @@ -60,52 +83,42 @@ ;; Bcdr_safe (cdr-safe x)) - (native-compile #'comp-tests-list-f) - (native-compile #'comp-tests-list2-f) - (native-compile #'comp-tests-car-f) - (native-compile #'comp-tests-cdr-f) - (native-compile #'comp-tests-car-safe-f) - (native-compile #'comp-tests-cdr-safe-f) - - (should (equal (comp-tests-list-f) '(1 2 3))) - (should (equal (comp-tests-list2-f 1 2 3) '(1 2 3))) - (should (= (comp-tests-car-f '(1 . 2)) 1)) - (should (null (comp-tests-car-f nil))) + (should (equal (comp-test-apply #'comp-tests-list-f) '(1 2 3))) + (should (equal (comp-test-apply #'comp-tests-list2-f 1 2 3) '(1 2 3))) + (should (= (comp-test-apply #'comp-tests-car-f '(1 . 2)) 1)) + (should (null (comp-test-apply #'comp-tests-car-f nil))) (should (= (condition-case err - (comp-tests-car-f 3) + (comp-test-apply #'comp-tests-car-f 3) (error 10)) 10)) - (should (= (comp-tests-cdr-f '(1 . 2)) 2)) - (should (null (comp-tests-cdr-f nil))) + (should (= (comp-test-apply #'comp-tests-cdr-f '(1 . 2)) 2)) + (should (null (comp-test-apply #'comp-tests-cdr-f nil))) (should (= (condition-case err - (comp-tests-cdr-f 3) + (comp-test-apply #'comp-tests-cdr-f 3) (error 10)) 10)) - (should (= (comp-tests-car-safe-f '(1 . 2)) 1)) - (should (null (comp-tests-car-safe-f 'a))) - (should (= (comp-tests-cdr-safe-f '(1 . 2)) 2)) - (should (null (comp-tests-cdr-safe-f 'a)))) + (should (= (comp-test-apply #'comp-tests-car-safe-f '(1 . 2)) 1)) + (should (null (comp-test-apply #'comp-tests-car-safe-f 'a))) + (should (= (comp-test-apply #'comp-tests-cdr-safe-f '(1 . 2)) 2)) + (should (null (comp-test-apply #'comp-tests-cdr-safe-f 'a)))) (ert-deftest comp-tests-cons-car-cdr () "Testing cons car cdr." (defun comp-tests-cons-car-f () (car (cons 1 2))) - (native-compile #'comp-tests-cons-car-f) (defun comp-tests-cons-cdr-f (x) (cdr (cons 'foo x))) - (native-compile #'comp-tests-cons-cdr-f) - (should (= (comp-tests-cons-car-f) 1)) - (should (= (comp-tests-cons-cdr-f 3) 3))) + (should (= (comp-test-apply #'comp-tests-cons-car-f) 1)) + (should (= (comp-test-apply #'comp-tests-cons-cdr-f 3) 3))) (ert-deftest comp-tests-varset () "Testing varset." (defun comp-tests-varset-f () (setq comp-tests-var1 55)) - (native-compile #'comp-tests-varset-f) - (comp-tests-varset-f) + (comp-test-apply #'comp-tests-varset-f) (should (= comp-tests-var1 55))) @@ -113,98 +126,91 @@ "Testing length." (defun comp-tests-length-f () (length '(1 2 3))) - (native-compile #'comp-tests-length-f) - (should (= (comp-tests-length-f) 3))) + (should (= (comp-test-apply #'comp-tests-length-f) 3))) -(ert-deftest comp-tests-aref-aset () +(ert-deftest comp-tests-aref-aset () "Testing aref and aset." (defun comp-tests-aref-aset-f () (let ((vec [1 2 3])) (aset vec 2 100) (aref vec 2))) - (native-compile #'comp-tests-aref-aset-f) - (should (= (comp-tests-aref-aset-f) 100))) + (should (= (comp-test-apply #'comp-tests-aref-aset-f) 100))) -(ert-deftest comp-tests-symbol-value () +(ert-deftest comp-tests-symbol-value () "Testing aref and aset." (defvar comp-tests-var2 3) (defun comp-tests-symbol-value-f () (symbol-value 'comp-tests-var2)) - (native-compile #'comp-tests-symbol-value-f) - (should (= (comp-tests-symbol-value-f) 3))) + (should (= (comp-test-apply #'comp-tests-symbol-value-f) 3))) -(ert-deftest comp-tests-concat () +(ert-deftest comp-tests-concat () "Testing concatX opcodes." (defun comp-tests-concat-f (x) (concat "a" "b" "c" "d" (concat "a" "b" "c" (concat "a" "b" (concat "foo" x))))) - (native-compile #'comp-tests-concat-f) - (should (string= (comp-tests-concat-f "bar") "abcdabcabfoobar"))) + (should (string= (comp-test-apply #'comp-tests-concat-f "bar") "abcdabcabfoobar"))) -(ert-deftest comp-tests-ffuncall () - "Test calling conventions." - (defun comp-tests-ffuncall-callee-f (x y z) +(defun comp-tests-ffuncall-callee-f (x y z) (list x y z)) + +(ert-deftest comp-tests-ffuncall () + "Test calling conventions." + (native-compile #'comp-tests-ffuncall-calle-f) (defun comp-tests-ffuncall-caller-f () (comp-tests-ffuncall-callee-f 1 2 3)) - (native-compile #'comp-tests-ffuncall-caller-f) - - (should (equal (comp-tests-ffuncall-caller-f) '(1 2 3))) + (should (equal (comp-test-apply #'comp-tests-ffuncall-caller-f) '(1 2 3))) (defun comp-tests-ffuncall-callee-optional-f (a b &optional c d) (list a b c d)) - (native-compile #'comp-tests-ffuncall-callee-optional-f) - (should (equal (comp-tests-ffuncall-callee-optional-f 1 2 3 4) '(1 2 3 4))) - (should (equal (comp-tests-ffuncall-callee-optional-f 1 2 3) '(1 2 3 nil))) - (should (equal (comp-tests-ffuncall-callee-optional-f 1 2) '(1 2 nil nil))) + (should (equal (comp-test-apply #'comp-tests-ffuncall-callee-optional-f 1 2 3 4) + '(1 2 3 4))) + (should (equal (comp-test-apply #'comp-tests-ffuncall-callee-optional-f 1 2 3) + '(1 2 3 nil))) + (should (equal (comp-test-apply #'comp-tests-ffuncall-callee-optional-f 1 2) + '(1 2 nil nil))) (defun comp-tests-ffuncall-callee-rest-f (a b &rest c) (list a b c)) - (native-compile #'comp-tests-ffuncall-callee-rest-f) - (should (equal (comp-tests-ffuncall-callee-rest-f 1 2) '(1 2 nil))) - (should (equal (comp-tests-ffuncall-callee-rest-f 1 2 3) '(1 2 (3)))) - (should (equal (comp-tests-ffuncall-callee-rest-f 1 2 3 4) '(1 2 (3 4)))) + (should (equal (comp-test-apply #'comp-tests-ffuncall-callee-rest-f 1 2) + '(1 2 nil))) + (should (equal (comp-test-apply #'comp-tests-ffuncall-callee-rest-f 1 2 3) + '(1 2 (3)))) + (should (equal (comp-test-apply #'comp-tests-ffuncall-callee-rest-f 1 2 3 4) + '(1 2 (3 4)))) (defun comp-tests-ffuncall-native-f () "Call a primitive with no dedicate op." (make-vector 1 nil)) - (native-compile #'comp-tests-ffuncall-native-f) - - (should (equal (comp-tests-ffuncall-native-f) [nil])) + (should (equal (comp-test-apply #'comp-tests-ffuncall-native-f) [nil])) (defun comp-tests-ffuncall-native-rest-f () "Call a primitive with no dedicate op with &rest." (vector 1 2 3)) - (native-compile #'comp-tests-ffuncall-native-rest-f) - - (should (equal (comp-tests-ffuncall-native-rest-f) [1 2 3])) + (should (equal (comp-test-apply #'comp-tests-ffuncall-native-rest-f) [1 2 3])) (defun comp-tests-ffuncall-apply-many-f (x) (apply #'list x)) - (native-compile #'comp-tests-ffuncall-apply-many-f) - - (should (equal (comp-tests-ffuncall-apply-many-f '(1 2 3)) '(1 2 3))) + (should (equal (comp-test-apply #'comp-tests-ffuncall-apply-many-f '(1 2 3)) + '(1 2 3))) (defun comp-tests-ffuncall-lambda-f (x) (let ((fun (lambda (x) (1+ x)))) (funcall fun x))) - (native-compile #'comp-tests-ffuncall-lambda-f) - - (should (= (comp-tests-ffuncall-lambda-f 1) 2))) + (should (= (comp-test-apply #'comp-tests-ffuncall-lambda-f 1) 2))) -(ert-deftest comp-tests-jump-table () +(ert-deftest comp-tests-jump-table () "Testing jump tables" (defun comp-tests-jump-table-1-f (x) (pcase x @@ -212,13 +218,11 @@ ('y 'b) (_ 'c))) - (native-compile #'comp-tests-jump-table-1-f) + (should (eq (comp-test-apply #'comp-tests-jump-table-1-f 'x) 'a)) + (should (eq (comp-test-apply #'comp-tests-jump-table-1-f 'y) 'b)) + (should (eq (comp-test-apply #'comp-tests-jump-table-1-f 'xxx) 'c))) - (should (eq (comp-tests-jump-table-1-f 'x) 'a)) - (should (eq (comp-tests-jump-table-1-f 'y) 'b)) - (should (eq (comp-tests-jump-table-1-f 'xxx) 'c))) - -(ert-deftest comp-tests-conditionals () +(ert-deftest comp-tests-conditionals () "Testing conditionals." (defun comp-tests-conditionals-1-f (x) ;; Generate goto-if-nil @@ -227,15 +231,13 @@ ;; Generate goto-if-nil-else-pop (when x 1340)) - (native-compile #'comp-tests-conditionals-1-f) - (native-compile #'comp-tests-conditionals-2-f) - (should (= (comp-tests-conditionals-1-f t) 1)) - (should (= (comp-tests-conditionals-1-f nil) 2)) - (should (= (comp-tests-conditionals-2-f t) 1340)) - (should (eq (comp-tests-conditionals-2-f nil) nil))) + (should (= (comp-test-apply #'comp-tests-conditionals-1-f t) 1)) + (should (= (comp-test-apply #'comp-tests-conditionals-1-f nil) 2)) + (should (= (comp-test-apply #'comp-tests-conditionals-2-f t) 1340)) + (should (eq (comp-test-apply #'comp-tests-conditionals-2-f nil) nil))) -(ert-deftest comp-tests-fixnum () +(ert-deftest comp-tests-fixnum () "Testing some fixnum inline operation." (defun comp-tests-fixnum-1-minus-f (x) ;; Bsub1 @@ -247,33 +249,29 @@ ;; Bnegate (- x)) - (native-compile #'comp-tests-fixnum-1-minus-f) - (native-compile #'comp-tests-fixnum-1-plus-f) - (native-compile #'comp-tests-fixnum-minus-f) - - (should (= (comp-tests-fixnum-1-minus-f 10) 9)) - (should (= (comp-tests-fixnum-1-minus-f most-negative-fixnum) + (should (= (comp-test-apply #'comp-tests-fixnum-1-minus-f 10) 9)) + (should (= (comp-test-apply #'comp-tests-fixnum-1-minus-f most-negative-fixnum) (1- most-negative-fixnum))) (should (equal (condition-case err (comp-tests-fixnum-1-minus-f 'a) (error err)) '(wrong-type-argument number-or-marker-p a))) - (should (= (comp-tests-fixnum-1-plus-f 10) 11)) - (should (= (comp-tests-fixnum-1-plus-f most-positive-fixnum) + (should (= (comp-test-apply #'comp-tests-fixnum-1-plus-f 10) 11)) + (should (= (comp-test-apply #'comp-tests-fixnum-1-plus-f most-positive-fixnum) (1+ most-positive-fixnum))) (should (equal (condition-case err (comp-tests-fixnum-1-plus-f 'a) (error err)) '(wrong-type-argument number-or-marker-p a))) - (should (= (comp-tests-fixnum-minus-f 10) -10)) - (should (= (comp-tests-fixnum-minus-f most-negative-fixnum) + (should (= (comp-test-apply #'comp-tests-fixnum-minus-f 10) -10)) + (should (= (comp-test-apply #'comp-tests-fixnum-minus-f most-negative-fixnum) (- most-negative-fixnum))) (should (equal (condition-case err (comp-tests-fixnum-minus-f 'a) (error err)) '(wrong-type-argument number-or-marker-p a)))) -(ert-deftest comp-tests-arith-comp () +(ert-deftest comp-tests-arith-comp () "Testing arithmetic comparisons." (defun comp-tests-eqlsign-f (x y) ;; Beqlsign @@ -291,27 +289,21 @@ ;; Bgeq (>= x y)) - (native-compile #'comp-tests-eqlsign-f) - (native-compile #'comp-tests-gtr-f) - (native-compile #'comp-tests-lss-f) - (native-compile #'comp-tests-les-f) - (native-compile #'comp-tests-geq-f) - - (should (eq (comp-tests-eqlsign-f 4 3) nil)) - (should (eq (comp-tests-eqlsign-f 3 3) t)) - (should (eq (comp-tests-eqlsign-f 2 3) nil)) - (should (eq (comp-tests-gtr-f 4 3) t)) - (should (eq (comp-tests-gtr-f 3 3) nil)) - (should (eq (comp-tests-gtr-f 2 3) nil)) - (should (eq (comp-tests-lss-f 4 3) nil)) - (should (eq (comp-tests-lss-f 3 3) nil)) - (should (eq (comp-tests-lss-f 2 3) t)) - (should (eq (comp-tests-les-f 4 3) nil)) - (should (eq (comp-tests-les-f 3 3) t)) - (should (eq (comp-tests-les-f 2 3) t)) - (should (eq (comp-tests-geq-f 4 3) t)) - (should (eq (comp-tests-geq-f 3 3) t)) - (should (eq (comp-tests-geq-f 2 3) nil))) + (should (eq (comp-test-apply #'comp-tests-eqlsign-f 4 3) nil)) + (should (eq (comp-test-apply #'comp-tests-eqlsign-f 3 3) t)) + (should (eq (comp-test-apply #'comp-tests-eqlsign-f 2 3) nil)) + (should (eq (comp-test-apply #'comp-tests-gtr-f 4 3) t)) + (should (eq (comp-test-apply #'comp-tests-gtr-f 3 3) nil)) + (should (eq (comp-test-apply #'comp-tests-gtr-f 2 3) nil)) + (should (eq (comp-test-apply #'comp-tests-lss-f 4 3) nil)) + (should (eq (comp-test-apply #'comp-tests-lss-f 3 3) nil)) + (should (eq (comp-test-apply #'comp-tests-lss-f 2 3) t)) + (should (eq (comp-test-apply #'comp-tests-les-f 4 3) nil)) + (should (eq (comp-test-apply #'comp-tests-les-f 3 3) t)) + (should (eq (comp-test-apply #'comp-tests-les-f 2 3) t)) + (should (eq (comp-test-apply #'comp-tests-geq-f 4 3) t)) + (should (eq (comp-test-apply #'comp-tests-geq-f 3 3) t)) + (should (eq (comp-test-apply #'comp-tests-geq-f 2 3) nil))) (ert-deftest comp-tests-setcarcdr () "Testing setcar setcdr." @@ -322,11 +314,8 @@ (setcdr x y) x) - (native-compile #'comp-tests-setcar-f) - (native-compile #'comp-tests-setcdr-f) - - (should (equal (comp-tests-setcar-f '(10 . 10) 3) '(3 . 10))) - (should (equal (comp-tests-setcdr-f '(10 . 10) 3) '(10 . 3))) + (should (equal (comp-test-apply #'comp-tests-setcar-f '(10 . 10) 3) '(3 . 10))) + (should (equal (comp-test-apply #'comp-tests-setcdr-f '(10 . 10) 3) '(10 . 3))) (should (equal (condition-case err (comp-tests-setcar-f 3 10) @@ -334,7 +323,7 @@ '(wrong-type-argument consp 3))) (should (equal (condition-case err - (comp-tests-setcdr-f 3 10) + (comp-test-apply #'comp-tests-setcdr-f 3 10) (error err)) '(wrong-type-argument consp 3)))) @@ -352,14 +341,12 @@ (setq i (1- i))) list)) - (native-compile #'comp-bubble-sort-f) - (let* ((list1 (mapcar 'random (make-list 1000 most-positive-fixnum))) (list2 (copy-sequence list1))) (should (equal (comp-bubble-sort-f list1) (sort list2 #'<))))) -(ert-deftest comp-tests-list-inline () +(ert-deftest comp-test-apply () "Test some inlined list functions." (defun comp-tests-consp-f (x) ;; Bconsp @@ -368,13 +355,10 @@ ;; Bsetcar (setcar x 3)) - (native-compile #'comp-tests-consp-f) - (native-compile #'comp-tests-car-f) - - (should (eq (comp-tests-consp-f '(1)) t)) - (should (eq (comp-tests-consp-f 1) nil)) + (should (eq (comp-test-apply #'comp-tests-consp-f '(1)) t)) + (should (eq (comp-test-apply #'comp-tests-consp-f 1) nil)) (let ((x (cons 1 2))) - (should (= (comp-tests-car-f x) 3)) + (should (= (comp-test-apply #'comp-tests-car-f x) 3)) (should (equal x '(3 . 2))))) (ert-deftest comp-tests-num-inline () @@ -386,17 +370,14 @@ ;; Bnumberp (numberp x)) - (native-compile #'comp-tests-integerp-f) - (native-compile #'comp-tests-numberp-f) - - (should (eq (comp-tests-integerp-f 1) t)) - (should (eq (comp-tests-integerp-f '(1)) nil)) - (should (eq (comp-tests-integerp-f 3.5) nil)) - (should (eq (comp-tests-integerp-f (1+ most-negative-fixnum)) t)) + (should (eq (comp-test-apply #'comp-tests-integerp-f 1) t)) + (should (eq (comp-test-apply #'comp-tests-integerp-f '(1)) nil)) + (should (eq (comp-test-apply #'comp-tests-integerp-f 3.5) nil)) + (should (eq (comp-test-apply #'comp-tests-integerp-f (1+ most-negative-fixnum)) t)) - (should (eq (comp-tests-numberp-f 1) t)) - (should (eq (comp-tests-numberp-f 'a) nil)) - (should (eq (comp-tests-numberp-f 3.5) t))) + (should (eq (comp-test-apply #'comp-tests-numberp-f 1) t)) + (should (eq (comp-test-apply #'comp-tests-numberp-f 'a) nil)) + (should (eq (comp-test-apply #'comp-tests-numberp-f 3.5) t))) (ert-deftest comp-tests-stack () "Test some stack operation." @@ -410,11 +391,7 @@ ;; Binsert (insert a b c d)) - (native-compile #'comp-tests-discardn-f) - (native-compile #'comp-tests-insertn-f) - - (should (= (comp-tests-discardn-f 10) 2)) - + (should (= (comp-test-apply #'comp-tests-discardn-f 10) 2)) (should (string= (with-temp-buffer (comp-tests-insertn-f "a" "b" "c" "d") (buffer-string)) @@ -459,16 +436,13 @@ (defun comp-tests-throw-f (x) (throw 'foo x)) - (native-compile #'comp-tests-condition-case-0-f) - (native-compile #'comp-tests-condition-case-1-f) - (native-compile #'comp-tests-catch-f) - (native-compile #'comp-tests-throw-f) - - (should (string= (comp-tests-condition-case-0-f) + (should (string= (comp-test-apply #'comp-tests-condition-case-0-f) "arith-error Arithmetic error catched")) - (should (string= (comp-tests-condition-case-1-f) + (should (string= (comp-test-apply #'comp-tests-condition-case-1-f) "error foo catched")) - (should (= (comp-tests-catch-f (lambda () (throw 'foo 3))) 3)) + (should (= (comp-test-apply #'comp-tests-catch-f + (lambda () (throw 'foo 3))) + 3)) (should (= (catch 'foo (comp-tests-throw-f 3)))))) @@ -477,17 +451,12 @@ (dotimes (_ 100000) (comp-tests-cons-cdr-f 3)) - (should (= (comp-tests-cons-cdr-f 3) 3))) + (should (= (comp-test-apply #'comp-tests-cons-cdr-f 3) 3))) ;;;;;;;;;;;;;;;;;;;; ;; Tromey's tests ;; ;;;;;;;;;;;;;;;;;;;; -(defun comp-test-apply (func &rest args) - (unless (subrp (symbol-function func)) - (native-compile func)) - (apply func args)) - ;; Test Bconsp. (defun comp-test-consp (x) (consp x)) commit b3dc6e8f06892869e0dcf39fd226b63752ce6cf9 Author: Andrea Corallo Date: Tue Aug 6 23:56:12 2019 +0200 fix gcc interruption diff --git a/src/comp.c b/src/comp.c index 16089beee1..54078e89bf 100644 --- a/src/comp.c +++ b/src/comp.c @@ -22,6 +22,7 @@ along with GNU Emacs. If not, see . */ #include #include +#include #include #include "lisp.h" @@ -2280,9 +2281,14 @@ DEFUN ("comp-compile-and-load-ctxt", Fcomp_compile_and_load_ctxt, gcc_jit_context_set_int_option (comp.ctxt, GCC_JIT_INT_OPTION_OPTIMIZATION_LEVEL, comp_speed); - /* Gcc doesn't like being interrupted. */ + /* Gcc doesn't like being interrupted at all. */ sigset_t oldset; - block_atimers (&oldset); + sigset_t blocked; + sigemptyset (&blocked); + sigaddset (&blocked, SIGALRM); + sigaddset (&blocked, SIGINT); + sigaddset (&blocked, SIGIO); + pthread_sigmask (SIG_BLOCK, &blocked, &oldset); if (COMP_DEBUG) gcc_jit_context_dump_to_file (comp.ctxt, "gcc-ctxt-dump.c", 1); commit f46bfdf3234548f664824b7c96838d3f918950d7 Author: Andrea Corallo Date: Tue Aug 6 23:06:28 2019 +0200 fix max_args diff --git a/src/comp.c b/src/comp.c index 7ca0aec45d..16089beee1 100644 --- a/src/comp.c +++ b/src/comp.c @@ -2185,11 +2185,11 @@ DEFUN ("comp-add-func-to-ctxt", Fcomp_add_func_to_ctxt, Scomp_add_func_to_ctxt, Lisp_Object args = FUNCALL1 (comp-func-args, func); EMACS_INT frame_size = XFIXNUM (FUNCALL1 (comp-func-frame-size, func)); /* EMACS_INT min_args = XFIXNUM (FUNCALL1 (comp-args-min, args)); */ - EMACS_INT max_args = XFIXNUM (FUNCALL1 (comp-args-max, args)); bool ncall = !NILP (FUNCALL1 (comp-args-ncall-conv, args)); if (!ncall) { + EMACS_INT max_args = XFIXNUM (FUNCALL1 (comp-args-max, args)); comp.func = emit_func_declare (c_name, comp.lisp_obj_type, max_args, NULL, GCC_JIT_FUNCTION_EXPORTED, false); commit 6465002b8a51d065a662cb589e8e1cf0a78ad160 Author: Andrea Corallo Date: Tue Aug 6 21:54:51 2019 +0200 add tromeys tests diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 96362ecf6e..332dd3f8c0 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -479,4 +479,284 @@ (should (= (comp-tests-cons-cdr-f 3) 3))) +;;;;;;;;;;;;;;;;;;;; +;; Tromey's tests ;; +;;;;;;;;;;;;;;;;;;;; + +(defun comp-test-apply (func &rest args) + (unless (subrp (symbol-function func)) + (native-compile func)) + (apply func args)) + +;; Test Bconsp. +(defun comp-test-consp (x) (consp x)) + +(ert-deftest comp-consp () + (should-not (comp-test-apply 'comp-test-consp 23)) + (should-not (comp-test-apply 'comp-test-consp nil)) + (should (comp-test-apply 'comp-test-consp '(1 . 2)))) + +;; Test Blistp. +(defun comp-test-listp (x) (listp x)) + +(ert-deftest comp-listp () + (should-not (comp-test-apply 'comp-test-listp 23)) + (should (comp-test-apply 'comp-test-listp nil)) + (should (comp-test-apply 'comp-test-listp '(1 . 2)))) + +;; Test Bstringp. +(defun comp-test-stringp (x) (stringp x)) + +(ert-deftest comp-stringp () + (should-not (comp-test-apply 'comp-test-stringp 23)) + (should-not (comp-test-apply 'comp-test-stringp nil)) + (should (comp-test-apply 'comp-test-stringp "hi"))) + +;; Test Bsymbolp. +(defun comp-test-symbolp (x) (symbolp x)) + +(ert-deftest comp-symbolp () + (should-not (comp-test-apply 'comp-test-symbolp 23)) + (should-not (comp-test-apply 'comp-test-symbolp "hi")) + (should (comp-test-apply 'comp-test-symbolp 'whatever))) + +;; Test Bintegerp. +(defun comp-test-integerp (x) (integerp x)) + +(ert-deftest comp-integerp () + (should (comp-test-apply 'comp-test-integerp 23)) + (should-not (comp-test-apply 'comp-test-integerp 57.5)) + (should-not (comp-test-apply 'comp-test-integerp "hi")) + (should-not (comp-test-apply 'comp-test-integerp 'whatever))) + +;; Test Bnumberp. +(defun comp-test-numberp (x) (numberp x)) + +(ert-deftest comp-numberp () + (should (comp-test-apply 'comp-test-numberp 23)) + (should (comp-test-apply 'comp-test-numberp 57.5)) + (should-not (comp-test-apply 'comp-test-numberp "hi")) + (should-not (comp-test-apply 'comp-test-numberp 'whatever))) + +;; Test Badd1. +(defun comp-test-add1 (x) (1+ x)) + +(ert-deftest comp-add1 () + (should (eq (comp-test-apply 'comp-test-add1 23) 24)) + (should (eq (comp-test-apply 'comp-test-add1 -17) -16)) + (should (eql (comp-test-apply 'comp-test-add1 1.0) 2.0)) + (should-error (comp-test-apply 'comp-test-add1 nil) + :type 'wrong-type-argument)) + +;; Test Bsub1. +(defun comp-test-sub1 (x) (1- x)) + +(ert-deftest comp-sub1 () + (should (eq (comp-test-apply 'comp-test-sub1 23) 22)) + (should (eq (comp-test-apply 'comp-test-sub1 -17) -18)) + (should (eql (comp-test-apply 'comp-test-sub1 1.0) 0.0)) + (should-error (comp-test-apply 'comp-test-sub1 nil) + :type 'wrong-type-argument)) + +;; Test Bneg. +(defun comp-test-negate (x) (- x)) + +(ert-deftest comp-negate () + (should (eq (comp-test-apply 'comp-test-negate 23) -23)) + (should (eq (comp-test-apply 'comp-test-negate -17) 17)) + (should (eql (comp-test-apply 'comp-test-negate 1.0) -1.0)) + (should-error (comp-test-apply 'comp-test-negate nil) + :type 'wrong-type-argument)) + +;; Test Bnot. +(defun comp-test-not (x) (not x)) + +(ert-deftest comp-not () + (should (eq (comp-test-apply 'comp-test-not 23) nil)) + (should (eq (comp-test-apply 'comp-test-not nil) t)) + (should (eq (comp-test-apply 'comp-test-not t) nil))) + +;; Test Bbobp, Beobp, Bpoint, Bpoint_min, Bpoint_max. +(defun comp-test-bobp () (bobp)) +(defun comp-test-eobp () (eobp)) +(defun comp-test-point () (point)) +(defun comp-test-point-min () (point-min)) +(defun comp-test-point-max () (point-max)) + +(ert-deftest comp-bobp-and-eobp () + (with-temp-buffer + (should (comp-test-apply 'comp-test-bobp)) + (should (comp-test-apply 'comp-test-eobp)) + (insert "hi") + (goto-char (point-min)) + (should (eq (comp-test-apply 'comp-test-point-min) (point-min))) + (should (eq (comp-test-apply 'comp-test-point) (point-min))) + (should (comp-test-apply 'comp-test-bobp)) + (should-not (comp-test-apply 'comp-test-eobp)) + (goto-char (point-max)) + (should (eq (comp-test-apply 'comp-test-point-max) (point-max))) + (should (eq (comp-test-apply 'comp-test-point) (point-max))) + (should-not (comp-test-apply 'comp-test-bobp)) + (should (comp-test-apply 'comp-test-eobp)))) + +;; Test Bcar and Bcdr. +(defun comp-test-car (x) (car x)) +(defun comp-test-cdr (x) (cdr x)) + +(ert-deftest comp-car-cdr () + (let ((pair '(1 . b))) + (should (eq (comp-test-apply 'comp-test-car pair) 1)) + (should (eq (comp-test-apply 'comp-test-car nil) nil)) + (should-error (comp-test-apply 'comp-test-car 23) + :type 'wrong-type-argument) + (should (eq (comp-test-apply 'comp-test-cdr pair) 'b)) + (should (eq (comp-test-apply 'comp-test-cdr nil) nil)) + (should-error (comp-test-apply 'comp-test-cdr 23) + :type 'wrong-type-argument))) + +;; Test Bcar_safe and Bcdr_safe. +(defun comp-test-car-safe (x) (car-safe x)) +(defun comp-test-cdr-safe (x) (cdr-safe x)) + +(ert-deftest comp-car-cdr-safe () + (let ((pair '(1 . b))) + (should (eq (comp-test-apply 'comp-test-car-safe pair) 1)) + (should (eq (comp-test-apply 'comp-test-car-safe nil) nil)) + (should (eq (comp-test-apply 'comp-test-car-safe 23) nil)) + (should (eq (comp-test-apply 'comp-test-cdr-safe pair) 'b)) + (should (eq (comp-test-apply 'comp-test-cdr-safe nil) nil)) + (should (eq (comp-test-apply 'comp-test-cdr-safe 23) nil)))) + +;; Test Beq. +(defun comp-test-eq (x y) (eq x y)) + +(ert-deftest comp-eq () + (should (comp-test-apply 'comp-test-eq 'a 'a)) + (should (comp-test-apply 'comp-test-eq 5 5)) + (should-not (comp-test-apply 'comp-test-eq 'a 'b)) + (should-not (comp-test-apply 'comp-test-eq "x" "x"))) + +;; Test Bgotoifnil. +(defun comp-test-if (x y) (if x x y)) + +(ert-deftest comp-if () + (should (eq (comp-test-apply 'comp-test-if 'a 'b) 'a)) + (should (eq (comp-test-apply 'comp-test-if 0 23) 0)) + (should (eq (comp-test-apply 'comp-test-if nil 'b) 'b))) + +;; Test Bgotoifnilelsepop. +(defun comp-test-and (x y) (and x y)) + +(ert-deftest comp-and () + (should (eq (comp-test-apply 'comp-test-and 'a 'b) 'b)) + (should (eq (comp-test-apply 'comp-test-and 0 23) 23)) + (should (eq (comp-test-apply 'comp-test-and nil 'b) nil))) + +;; Test Bgotoifnonnilelsepop. +(defun comp-test-or (x y) (or x y)) + +(ert-deftest comp-or () + (should (eq (comp-test-apply 'comp-test-or 'a 'b) 'a)) + (should (eq (comp-test-apply 'comp-test-or 0 23) 0)) + (should (eq (comp-test-apply 'comp-test-or nil 'b) 'b))) + +;; Test Bsave_excursion. +(defun comp-test-save-excursion () + (save-excursion + (insert "XYZ"))) + +;; Test Bcurrent_buffer. +(defun comp-test-current-buffer () (current-buffer)) + +(ert-deftest comp-save-excursion () + (with-temp-buffer + (comp-test-apply 'comp-test-save-excursion) + (should (eq (point) (point-min))) + (should (eq (comp-test-apply 'comp-test-current-buffer) (current-buffer))))) + +;; Test Bgtr. +(defun comp-test-> (a b) + (> a b)) + +(ert-deftest comp-> () + (should (eq (comp-test-apply 'comp-test-> 0 23) nil)) + (should (eq (comp-test-apply 'comp-test-> 23 0) t))) + +;; Test Bpushcatch. +(defun comp-test-catch (&rest l) + (catch 'done + (dolist (v l) + (when (> v 23) + (throw 'done v))))) + +(ert-deftest comp-catch () + (should (eq (comp-test-apply 'comp-test-catch 0 1 2 3 4) nil)) + (should (eq (comp-test-apply 'comp-test-catch 20 21 22 23 24 25 26 27 28) 24))) + +;; Test Bmemq. +(defun comp-test-memq (val list) + (memq val list)) + +(ert-deftest comp-memq () + (should (equal (comp-test-apply 'comp-test-memq 0 '(5 4 3 2 1 0)) '(0))) + (should (eq (comp-test-apply 'comp-test-memq 72 '(5 4 3 2 1 0)) nil))) + +;; Test BlistN. +(defun comp-test-listN (x) + (list x x x x x x x x x x x x x x x x)) + +(ert-deftest comp-listN () + (should (equal (comp-test-apply 'comp-test-listN 57) + '(57 57 57 57 57 57 57 57 57 57 57 57 57 57 57 57)))) + +;; Test BconcatN. +(defun comp-test-concatN (x) + (concat x x x x x x)) + +(ert-deftest comp-concatN () + (should (equal (comp-test-apply 'comp-test-concatN "x") "xxxxxx"))) + +;; Test optional and rest arguments. +(defun comp-test-opt-rest (a &optional b &rest c) + (list a b c)) + +(ert-deftest comp-opt-rest () + (should (equal (comp-test-apply 'comp-test-opt-rest 1) '(1 nil nil))) + (should (equal (comp-test-apply 'comp-test-opt-rest 1 2) '(1 2 nil))) + (should (equal (comp-test-apply 'comp-test-opt-rest 1 2 3) '(1 2 (3)))) + (should (equal (comp-test-apply 'comp-test-opt-rest 1 2 56 57 58) + '(1 2 (56 57 58))))) + +;; Test for too many arguments. +(defun comp-test-opt (a &optional b) + (cons a b)) + +(ert-deftest comp-opt () + (should (equal (comp-test-apply 'comp-test-opt 23) '(23))) + (should (equal (comp-test-apply 'comp-test-opt 23 24) '(23 . 24))) + (should-error (comp-test-apply 'comp-test-opt) + :type 'wrong-number-of-arguments) + (should-error (comp-test-apply 'comp-test-opt nil 24 97) + :type 'wrong-number-of-arguments)) + +;; Test for unwind-protect. +(defvar comp-test-up-val nil) +(defun comp-test-unwind-protect (fun) + (setq comp-test-up-val nil) + (unwind-protect + (progn + (setq comp-test-up-val 23) + (funcall fun) + (setq comp-test-up-val 24)) + (setq comp-test-up-val 999))) + +(ert-deftest comp-unwind-protect () + (comp-test-unwind-protect 'ignore) + (should (eq comp-test-up-val 999)) + (condition-case nil + (comp-test-unwind-protect (lambda () (error "HI"))) + (error + nil)) + (should (eq comp-test-up-val 999))) + ;;; comp-tests.el ends here commit dba7034ea10fb394b0dcf91256b7df094218119f Author: Andrea Corallo Date: Tue Aug 6 18:41:41 2019 +0200 insert page breaks diff --git a/src/comp.c b/src/comp.c index 5a5ac69e62..7ca0aec45d 100644 --- a/src/comp.c +++ b/src/comp.c @@ -948,6 +948,11 @@ emit_PURE_P (gcc_jit_rvalue *ptr) PURESIZE)); } + +/*************************************/ +/* Code emittes by LIMPLE statemes. */ +/*************************************/ + /* Emit an r-value from an mvar meta variable. In case this is a constant that was propagated return it otherwise load it from frame. */ @@ -979,7 +984,7 @@ emit_mvar_val (Lisp_Object mvar) } static void -emit_ncall_prolog (EMACS_UINT n) +emit_limple_ncall_prolog (EMACS_UINT n) { /* nargs will be known at runtime therfore we emit: @@ -1046,7 +1051,6 @@ emit_ncall_prolog (EMACS_UINT n) list_args)); } - static gcc_jit_rvalue * emit_limple_call (Lisp_Object arg1) { @@ -1285,7 +1289,7 @@ emit_limple_insn (Lisp_Object insn) else if (EQ (op, Qncall_prolog)) { /* Ex: (ncall-prolog 2). */ - emit_ncall_prolog (XFIXNUM (arg0)); + emit_limple_ncall_prolog (XFIXNUM (arg0)); } else if (EQ (op, Qsetimm)) { @@ -1310,6 +1314,11 @@ emit_limple_insn (Lisp_Object insn) } } + +/****************************************************************/ +/* Inline function definition and lisp data structure follows. */ +/****************************************************************/ + /* struct Lisp_Cons definition. */ static void @@ -1998,6 +2007,11 @@ define_bool_to_lisp_obj (void) } + +/**********************************/ +/* Entry points exposed to lisp. */ +/**********************************/ + DEFUN ("comp-init-ctxt", Fcomp_init_ctxt, Scomp_init_ctxt, 0, 0, 0, doc: /* Initialize the native compiler context. Return t on success. */) @@ -2341,11 +2355,14 @@ syms_of_comp (void) } + /******************************************************************************/ /* Helper functions called from the runtime. */ /* These can't be statics till shared mechanism is used to solve relocations. */ /******************************************************************************/ +/* TODO: cleanup */ + Lisp_Object helper_save_window_excursion (Lisp_Object v1); void helper_unwind_protect (Lisp_Object handler); commit 63bcc81d1df8524b20dab1fd45b2cba4d822a786 Author: Andrea Corallo Date: Sun Aug 4 20:14:50 2019 +0200 add incoming &rest arg support diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 71dd016ab0..9e62f88896 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -669,14 +669,18 @@ the annotation emission." (comp-pass (make-comp-limplify :sp -1 :frame (comp-new-frame frame-size))) + (args-min (comp-args-min (comp-func-args func))) (comp-block ())) ;; Prologue (comp-emit-block 'entry) (comp-emit-annotation (concat "Lisp function: " (symbol-name (comp-func-symbol-name func)))) - (cl-loop for i below (comp-args-max (comp-func-args func)) - do (cl-incf (comp-sp)) - do (comp-emit `(setpar ,(comp-slot) ,i))) + (if (not (comp-args-ncall-conv (comp-func-args func))) + (cl-loop for i below (comp-args-max (comp-func-args func)) + do (cl-incf (comp-sp)) + do (comp-emit `(setpar ,(comp-slot) ,i))) + (comp-emit `(ncall-prolog ,args-min)) + (cl-incf (comp-sp) (1+ args-min))) ;; Body (comp-emit-block 'bb_1) (mapc #'comp-limplify-lap-inst (comp-func-lap func)) diff --git a/src/comp.c b/src/comp.c index c7f68c7078..5a5ac69e62 100644 --- a/src/comp.c +++ b/src/comp.c @@ -404,34 +404,34 @@ emit_cast (gcc_jit_type *new_type, gcc_jit_rvalue *obj) (typeof_ptr) ((uintptr) ptr + size_of_ptr_ref * i) */ -/* static gcc_jit_rvalue * */ -/* emit_ptr_arithmetic (gcc_jit_rvalue *ptr, gcc_jit_type *ptr_type, */ -/* int size_of_ptr_ref, gcc_jit_rvalue *i) */ -/* { */ -/* emit_comment ("ptr_arithmetic"); */ +static gcc_jit_rvalue * +emit_ptr_arithmetic (gcc_jit_rvalue *ptr, gcc_jit_type *ptr_type, + int size_of_ptr_ref, gcc_jit_rvalue *i) +{ + emit_comment ("ptr_arithmetic"); -/* gcc_jit_rvalue *offset = */ -/* gcc_jit_context_new_binary_op ( */ -/* comp.ctxt, */ -/* NULL, */ -/* GCC_JIT_BINARY_OP_MULT, */ -/* comp.uintptr_type, */ -/* gcc_jit_context_new_rvalue_from_int (comp.ctxt, */ -/* comp.uintptr_type, */ -/* size_of_ptr_ref), */ -/* emit_cast (comp.uintptr_type, i)); */ - -/* return */ -/* emit_cast ( */ -/* ptr_type, */ -/* gcc_jit_context_new_binary_op ( */ -/* comp.ctxt, */ -/* NULL, */ -/* GCC_JIT_BINARY_OP_PLUS, */ -/* comp.uintptr_type, */ -/* emit_cast (comp.uintptr_type, ptr), */ -/* offset)); */ -/* } */ + gcc_jit_rvalue *offset = + gcc_jit_context_new_binary_op ( + comp.ctxt, + NULL, + GCC_JIT_BINARY_OP_MULT, + comp.uintptr_type, + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.uintptr_type, + size_of_ptr_ref), + emit_cast (comp.uintptr_type, i)); + + return + emit_cast ( + ptr_type, + gcc_jit_context_new_binary_op ( + comp.ctxt, + NULL, + GCC_JIT_BINARY_OP_PLUS, + comp.uintptr_type, + emit_cast (comp.uintptr_type, ptr), + offset)); +} INLINE static gcc_jit_rvalue * emit_XLI (gcc_jit_rvalue *obj) @@ -978,6 +978,75 @@ emit_mvar_val (Lisp_Object mvar) } } +static void +emit_ncall_prolog (EMACS_UINT n) +{ + /* + nargs will be known at runtime therfore we emit: + + prologue: + local[0] = *args; + ++args; + . + . + . + local[min_args - 1] = *args; + ++args; + local[min_args] = list (nargs - min_args, args); + bb_1: + . + . + . + */ + gcc_jit_lvalue *nargs = + gcc_jit_param_as_lvalue (gcc_jit_function_get_param (comp.func, 0)); + gcc_jit_lvalue *args = + gcc_jit_param_as_lvalue (gcc_jit_function_get_param (comp.func, 1)); + gcc_jit_rvalue *min_args = + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.ptrdiff_type, + n); + + for (ptrdiff_t i = 0; i < n; ++i) + { + gcc_jit_block_add_assignment (comp.block, + NULL, + comp.frame[i], + gcc_jit_lvalue_as_rvalue ( + gcc_jit_rvalue_dereference ( + gcc_jit_lvalue_as_rvalue (args), + NULL))); + + gcc_jit_block_add_assignment (comp.block, + NULL, + args, + emit_ptr_arithmetic ( + gcc_jit_lvalue_as_rvalue (args), + comp.lisp_obj_ptr_type, + sizeof (Lisp_Object), + comp.one)); + } + + /* + rest arguments + */ + gcc_jit_rvalue *list_args[] = + { gcc_jit_context_new_binary_op (comp.ctxt, + NULL, + GCC_JIT_BINARY_OP_MINUS, + comp.ptrdiff_type, + gcc_jit_lvalue_as_rvalue (nargs), + min_args), + gcc_jit_lvalue_as_rvalue (args) }; + + gcc_jit_block_add_assignment (comp.block, + NULL, + comp.frame[n], + emit_call ("Flist", comp.lisp_obj_type, 2, + list_args)); +} + + static gcc_jit_rvalue * emit_limple_call (Lisp_Object arg1) { @@ -1202,7 +1271,7 @@ emit_limple_insn (Lisp_Object insn) } else if (EQ (op, Qsetpar)) { - /* Ex: (=par #s(comp-mvar 2 0 nil nil nil) 0). */ + /* Ex: (setpar #s(comp-mvar 2 0 nil nil nil) 0). */ EMACS_UINT slot_n = XFIXNUM (FUNCALL1 (comp-mvar-slot, arg0)); EMACS_UINT param_n = XFIXNUM (SECOND (args)); gcc_jit_rvalue *param = @@ -1213,6 +1282,11 @@ emit_limple_insn (Lisp_Object insn) comp.frame[slot_n], param); } + else if (EQ (op, Qncall_prolog)) + { + /* Ex: (ncall-prolog 2). */ + emit_ncall_prolog (XFIXNUM (arg0)); + } else if (EQ (op, Qsetimm)) { /* EX: (=imm #s(comp-mvar 9 1 t 3 nil) 3). */ @@ -2108,7 +2182,21 @@ DEFUN ("comp-add-func-to-ctxt", Fcomp_add_func_to_ctxt, Scomp_add_func_to_ctxt, } else { - error ("Not supported for now"); + gcc_jit_param *param[] = + { gcc_jit_context_new_param (comp.ctxt, + NULL, + comp.ptrdiff_type, + "nargs"), + gcc_jit_context_new_param (comp.ctxt, + NULL, + comp.lisp_obj_ptr_type, + "args") }; + comp.func = + gcc_jit_context_new_function (comp.ctxt, + NULL, + GCC_JIT_FUNCTION_EXPORTED, + comp.lisp_obj_type, + c_name, 2, param, 0); } gcc_jit_lvalue *frame_array = @@ -2204,7 +2292,10 @@ DEFUN ("comp-compile-and-load-ctxt", Fcomp_compile_and_load_ctxt, x->s.function.a0 = gcc_jit_result_get_code(gcc_res, c_name); eassert (x->s.function.a0); x->s.min_args = XFIXNUM (FUNCALL1 (comp-args-min, args)); - x->s.max_args = XFIXNUM (FUNCALL1 (comp-args-max, args)); + if (NILP (FUNCALL1 (comp-args-ncall-conv, args))) + x->s.max_args = XFIXNUM (FUNCALL1 (comp-args-max, args)); + else + x->s.max_args = MANY; x->s.symbol_name = symbol_name; defsubr(x); @@ -2226,6 +2317,7 @@ syms_of_comp (void) DEFSYM (Qcallref, "callref"); DEFSYM (Qncall, "ncall"); DEFSYM (Qsetpar, "setpar"); + DEFSYM (Qncall_prolog, "ncall-prolog"); DEFSYM (Qsetimm, "setimm"); DEFSYM (Qreturn, "return"); DEFSYM (Qcomp_mvar, "comp-mvar"); diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 7cf2a12f4a..96362ecf6e 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -164,13 +164,13 @@ (should (equal (comp-tests-ffuncall-callee-optional-f 1 2 3) '(1 2 3 nil))) (should (equal (comp-tests-ffuncall-callee-optional-f 1 2) '(1 2 nil nil))) - ;; (defun comp-tests-ffuncall-callee-rest-f (a b &rest c) - ;; (list a b c)) - ;; (native-compile #'comp-tests-ffuncall-callee-rest-f) + (defun comp-tests-ffuncall-callee-rest-f (a b &rest c) + (list a b c)) + (native-compile #'comp-tests-ffuncall-callee-rest-f) - ;; (should (equal (comp-tests-ffuncall-callee-rest-f 1 2) '(1 2 nil))) - ;; (should (equal (comp-tests-ffuncall-callee-rest-f 1 2 3) '(1 2 (3)))) - ;; (should (equal (comp-tests-ffuncall-callee-rest-f 1 2 3 4) '(1 2 (3 4)))) + (should (equal (comp-tests-ffuncall-callee-rest-f 1 2) '(1 2 nil))) + (should (equal (comp-tests-ffuncall-callee-rest-f 1 2 3) '(1 2 (3)))) + (should (equal (comp-tests-ffuncall-callee-rest-f 1 2 3 4) '(1 2 (3 4)))) (defun comp-tests-ffuncall-native-f () "Call a primitive with no dedicate op." @@ -291,7 +291,6 @@ ;; Bgeq (>= x y)) - (native-compile #'comp-tests-eqlsign-f) (native-compile #'comp-tests-gtr-f) (native-compile #'comp-tests-lss-f) commit c77ad1866d0e559db41118ad5a2c306c81fa3c21 Author: Andrea Corallo Date: Sat Aug 3 19:14:35 2019 +0200 add incoming &optional args support diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 71d747428d..71dd016ab0 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -674,10 +674,9 @@ the annotation emission." (comp-emit-block 'entry) (comp-emit-annotation (concat "Lisp function: " (symbol-name (comp-func-symbol-name func)))) - (cl-loop for i below (comp-args-min (comp-func-args func)) - do (progn - (cl-incf (comp-sp)) - (comp-emit `(setpar ,(comp-slot) ,i)))) + (cl-loop for i below (comp-args-max (comp-func-args func)) + do (cl-incf (comp-sp)) + do (comp-emit `(setpar ,(comp-slot) ,i))) ;; Body (comp-emit-block 'bb_1) (mapc #'comp-limplify-lap-inst (comp-func-lap func)) diff --git a/src/comp.c b/src/comp.c index e4483ea420..c7f68c7078 100644 --- a/src/comp.c +++ b/src/comp.c @@ -2096,14 +2096,14 @@ DEFUN ("comp-add-func-to-ctxt", Fcomp_add_func_to_ctxt, Scomp_add_func_to_ctxt, char *c_name = (char *) SDATA (FUNCALL1 (comp-func-c-func-name, func)); Lisp_Object args = FUNCALL1 (comp-func-args, func); EMACS_INT frame_size = XFIXNUM (FUNCALL1 (comp-func-frame-size, func)); - EMACS_INT min_args = XFIXNUM (FUNCALL1 (comp-args-min, args)); - /* EMACS_INT max_args = XFIXNUM (FUNCALL1 (comp-args-max, args)); */ - bool ncall = !NILP (FUNCALL1 (comp-args-ncall-conv, args)); + /* EMACS_INT min_args = XFIXNUM (FUNCALL1 (comp-args-min, args)); */ + EMACS_INT max_args = XFIXNUM (FUNCALL1 (comp-args-max, args)); + bool ncall = !NILP (FUNCALL1 (comp-args-ncall-conv, args)); if (!ncall) { comp.func = - emit_func_declare (c_name, comp.lisp_obj_type, min_args, + emit_func_declare (c_name, comp.lisp_obj_type, max_args, NULL, GCC_JIT_FUNCTION_EXPORTED, false); } else @@ -2204,7 +2204,7 @@ DEFUN ("comp-compile-and-load-ctxt", Fcomp_compile_and_load_ctxt, x->s.function.a0 = gcc_jit_result_get_code(gcc_res, c_name); eassert (x->s.function.a0); x->s.min_args = XFIXNUM (FUNCALL1 (comp-args-min, args)); - x->s.max_args = XFIXNUM (FUNCALL1 (comp-args-min, args)); + x->s.max_args = XFIXNUM (FUNCALL1 (comp-args-max, args)); x->s.symbol_name = symbol_name; defsubr(x); diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 9fbff7639e..7cf2a12f4a 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -156,13 +156,13 @@ (should (equal (comp-tests-ffuncall-caller-f) '(1 2 3))) - ;; (defun comp-tests-ffuncall-callee-optional-f (a b &optional c d) - ;; (list a b c d)) - ;; (native-compile #'comp-tests-ffuncall-callee-optional-f) + (defun comp-tests-ffuncall-callee-optional-f (a b &optional c d) + (list a b c d)) + (native-compile #'comp-tests-ffuncall-callee-optional-f) - ;; (should (equal (comp-tests-ffuncall-callee-optional-f 1 2 3 4) '(1 2 3 4))) - ;; (should (equal (comp-tests-ffuncall-callee-optional-f 1 2 3) '(1 2 3 nil))) - ;; (should (equal (comp-tests-ffuncall-callee-optional-f 1 2) '(1 2 nil nil))) + (should (equal (comp-tests-ffuncall-callee-optional-f 1 2 3 4) '(1 2 3 4))) + (should (equal (comp-tests-ffuncall-callee-optional-f 1 2 3) '(1 2 3 nil))) + (should (equal (comp-tests-ffuncall-callee-optional-f 1 2) '(1 2 nil nil))) ;; (defun comp-tests-ffuncall-callee-rest-f (a b &rest c) ;; (list a b c)) commit 318c4772af4fa04fd8dc498bdc252b691b3cdab5 Author: Andrea Corallo Date: Sat Aug 3 19:42:57 2019 +0200 fix comp-limplify-listn diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 4841753172..71d747428d 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -381,7 +381,7 @@ If NEGATED non nil negate the tested condition." (defun comp-limplify-listn (n) "Limplify list N." - (comp-with-sp (1- n) + (comp-with-sp (+ (comp-sp) n -1) (comp-emit-set-call `(call Fcons ,(comp-slot) ,(make-comp-mvar :constant nil)))) diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 58846ed50d..9fbff7639e 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -45,6 +45,8 @@ "Testing cons car cdr." (defun comp-tests-list-f () (list 1 2 3)) + (defun comp-tests-list2-f (a b c) + (list a b c)) (defun comp-tests-car-f (x) ;; Bcar (car x)) @@ -59,12 +61,14 @@ (cdr-safe x)) (native-compile #'comp-tests-list-f) + (native-compile #'comp-tests-list2-f) (native-compile #'comp-tests-car-f) (native-compile #'comp-tests-cdr-f) (native-compile #'comp-tests-car-safe-f) (native-compile #'comp-tests-cdr-safe-f) (should (equal (comp-tests-list-f) '(1 2 3))) + (should (equal (comp-tests-list2-f 1 2 3) '(1 2 3))) (should (= (comp-tests-car-f '(1 . 2)) 1)) (should (null (comp-tests-car-f nil))) (should (= (condition-case err commit bebe5a9791f7db3f088e0c07b2fd68e1d21bb161 Author: Andrea Corallo Date: Sat Aug 3 17:08:55 2019 +0200 add limple switch support diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 69f4382294..4841753172 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -355,11 +355,11 @@ If DST-N is specified use it otherwise assume it to be the current slot." (comp-block-sp (gethash block-name blocks))) (setf (comp-limplify-block-name comp-pass) block-name))) -(defun comp-emit-cond-jump (target-offset lap-label negated) - "Emit a conditional jump to LAP-LABEL. +(defun comp-emit-cond-jump (a b target-offset lap-label negated) + "Emit a conditional jump to LAP-LABEL when A and B satisfy EQ. TARGET-OFFSET is the positive offset on the SP when branching to the target block. -If NEGATED non nil negate the test condition." +If NEGATED non nil negate the tested condition." (let ((blocks (comp-func-blocks comp-func)) (bb (comp-new-block-sym))) ;; Fall through block (puthash bb @@ -367,8 +367,8 @@ If NEGATED non nil negate the test condition." blocks) (let ((target (comp-lap-to-limple-bb lap-label))) (comp-emit (if negated - (list 'cond-jump (comp-slot-next) target bb) - (list 'cond-jump (comp-slot-next) bb target))) + (list 'cond-jump a b target bb) + (list 'cond-jump a b bb target))) (puthash target (make-comp-block :sp (+ target-offset (comp-sp))) blocks) @@ -423,6 +423,14 @@ If NEGATED non nil negate the test condition." (comp-mark-block-closed) (comp-emit-block guarded-bb)))) +(defun comp-emit-switch (var m-hash) + "Emit a limple for a lap jump table given VAR and M-HASH." + (cl-assert (comp-mvar-const-vld m-hash)) + (cl-loop for test being each hash-keys of (comp-mvar-constant m-hash) + using (hash-value target-label) + for m-test = (make-comp-mvar :constant test) + do (comp-emit-cond-jump var m-test 0 target-label nil))) + (defmacro comp-op-case (&rest cases) "Expand CASES into the corresponding pcase. This is responsible for generating the proper stack adjustment when known and @@ -583,13 +591,17 @@ the annotation emission." (byte-goto (comp-emit-jump (comp-lap-to-limple-bb (cl-third insn)))) (byte-goto-if-nil - (comp-emit-cond-jump 0 (cl-third insn) nil)) + (comp-emit-cond-jump (comp-slot-next) (make-comp-mvar :constant nil) 0 + (cl-third insn) nil)) (byte-goto-if-not-nil - (comp-emit-cond-jump 0 (cl-third insn) t)) + (comp-emit-cond-jump (comp-slot-next) (make-comp-mvar :constant nil) 0 + (cl-third insn) t)) (byte-goto-if-nil-else-pop - (comp-emit-cond-jump 1 (cl-third insn) nil)) + (comp-emit-cond-jump (comp-slot-next) (make-comp-mvar :constant nil) 1 + (cl-third insn) nil)) (byte-goto-if-not-nil-else-pop - (comp-emit-cond-jump 1 (cl-third insn) t)) + (comp-emit-cond-jump (comp-slot-next) (make-comp-mvar :constant nil) 1 + (cl-third insn) t)) (byte-return (comp-emit (list 'return (comp-slot-next))) (comp-mark-block-closed)) @@ -642,7 +654,8 @@ the annotation emission." (byte-stack-set2) (byte-discardN (comp-stack-adjust (- arg))) - (byte-switch) + (byte-switch + (comp-emit-switch (comp-slot-next) (comp-slot-n (+ 2 (comp-sp))))) (byte-constant (comp-emit-set-const arg)) (byte-discardN-preserve-tos diff --git a/src/comp.c b/src/comp.c index 6436a5db71..e4483ea420 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1128,11 +1128,12 @@ emit_limple_insn (Lisp_Object insn) else if (EQ (op, Qcond_jump)) { /* Conditional branch. */ - gcc_jit_rvalue *test = emit_mvar_val (arg0); - gcc_jit_block *target1 = retrive_block (SECOND (args)); - gcc_jit_block *target2 = retrive_block (THIRD (args)); + gcc_jit_rvalue *a = emit_mvar_val (arg0); + gcc_jit_rvalue *b = emit_mvar_val (SECOND (args)); + gcc_jit_block *target1 = retrive_block (THIRD (args)); + gcc_jit_block *target2 = retrive_block (FORTH (args)); - emit_cond_jump (emit_NILP (test), target2, target1); + emit_cond_jump (emit_EQ (a, b), target2, target1); } else if (EQ (op, Qpush_handler)) { diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index ed3a9b2f9d..58846ed50d 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -200,18 +200,19 @@ (should (= (comp-tests-ffuncall-lambda-f 1) 2))) -;; (ert-deftest comp-tests-jump-table () -;; "Testing jump tables" -;; (defun comp-tests-jump-table-1-f (x) -;; (pcase x -;; ('x 'a) -;; ('y 'b) -;; (_ 'c))) - - -;; (should (eq (comp-tests-jump-table-1-f 'x) 'a)) -;; (should (eq (comp-tests-jump-table-1-f 'y) 'b)) -;; (should (eq (comp-tests-jump-table-1-f 'xxx) 'c))) +(ert-deftest comp-tests-jump-table () + "Testing jump tables" + (defun comp-tests-jump-table-1-f (x) + (pcase x + ('x 'a) + ('y 'b) + (_ 'c))) + + (native-compile #'comp-tests-jump-table-1-f) + + (should (eq (comp-tests-jump-table-1-f 'x) 'a)) + (should (eq (comp-tests-jump-table-1-f 'y) 'b)) + (should (eq (comp-tests-jump-table-1-f 'xxx) 'c))) (ert-deftest comp-tests-conditionals () "Testing conditionals." commit 79f7d40fa850806450621f2fa4c73974399bd7f9 Author: Andrea Corallo Date: Sat Aug 3 16:15:37 2019 +0200 better make-comp-mvar diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 005a7d0eb0..69f4382294 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -140,8 +140,8 @@ LIMPLE basic block.") (defun comp-pretty-print-func (func) "Pretty print function FUNC in the current buffer." (insert (format "\n\n Function: %s" (comp-func-symbol-name func))) - (cl-loop for bb being each hash-values of (comp-func-blocks func) - using (hash-key block-name) + (cl-loop for block-name being each hash-keys of (comp-func-blocks func) + using (hash-value bb) do (progn (insert (concat "\n<" (symbol-name block-name) ">")) (cl-prettyprint (comp-block-insns bb))))) @@ -216,7 +216,7 @@ LIMPLE basic block.") do (aset v i (make-comp-mvar :slot i))) v)) -(cl-defun make-comp-mvar (&key slot const-vld constant type) +(cl-defun make-comp-mvar (&key slot (constant nil const-vld) type) (make--comp-mvar :id (cl-incf (comp-func-ssa-cnt comp-func)) :slot slot :const-vld const-vld :constant constant :type type)) @@ -315,7 +315,6 @@ If DST-N is specified use it otherwise assume it to be the current slot." (defun comp-emit-set-const (val) "Set constant VAL to current slot." (setf (comp-slot) (make-comp-mvar :slot (comp-sp) - :const-vld t :constant val)) (comp-emit (list 'setimm (comp-slot) val))) @@ -385,8 +384,7 @@ If NEGATED non nil negate the test condition." (comp-with-sp (1- n) (comp-emit-set-call `(call Fcons ,(comp-slot) - ,(make-comp-mvar :const-vld t - :constant nil)))) + ,(make-comp-mvar :constant nil)))) (cl-loop for sp from (+ (comp-sp) n -2) downto (comp-sp) do (comp-with-sp sp (comp-emit-set-call `(call Fcons @@ -481,27 +479,22 @@ the annotation emission." (comp-copy-slot (- (comp-sp) arg 1))) (byte-varref (comp-emit-set-call `(call Fsymbol_value ,(make-comp-mvar - :const-vld t :constant arg)))) (byte-varset (comp-emit `(call set_internal - ,(make-comp-mvar :const-vld t - :constant arg) + ,(make-comp-mvar :constant arg) ,(comp-slot)))) (byte-varbind (comp-emit `(call specbind - ,(make-comp-mvar :const-vld t - :constant arg) + ,(make-comp-mvar :constant arg) ,(comp-slot-next)))) (byte-call (comp-stack-adjust (- arg)) (comp-emit-set-call `(callref Ffuncall ,(1+ arg) ,(comp-sp)))) (byte-unbind (comp-emit `(call unbind_to - ,(make-comp-mvar :const-vld t - :constant arg) - ,(make-comp-mvar :const-vld t - :constant nil)))) + ,(make-comp-mvar :constant arg) + ,(make-comp-mvar :constant nil)))) (byte-pophandler (comp-emit '(pop-handler))) (byte-pushconditioncase @@ -672,7 +665,6 @@ the annotation emission." do (progn (cl-incf (comp-sp)) (comp-emit `(setpar ,(comp-slot) ,i)))) - (comp-emit-jump 'bb_1) ;; Body (comp-emit-block 'bb_1) (mapc #'comp-limplify-lap-inst (comp-func-lap func)) commit 1b72dad74f2e193e8da8de58ef8c46341897269a Author: Andrea Corallo Date: Mon Jul 22 11:08:53 2019 +0200 catch works diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 35a59dbe60..005a7d0eb0 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -407,6 +407,24 @@ If NEGATED non nil negate the test condition." (puthash n name hash) name)))) +(defun comp-emit-handler (guarded-label handler-type) + "Emit a non local exit handler for GUARDED-LABEL of type HANDLER-TYPE." + (let ((blocks (comp-func-blocks comp-func)) + (guarded-bb (comp-new-block-sym))) + (puthash guarded-bb + (make-comp-block :sp (comp-sp)) + blocks) + (let ((handler-bb (comp-lap-to-limple-bb guarded-label))) + (comp-emit (list 'push-handler (comp-slot-next) + handler-type + handler-bb + guarded-bb)) + (puthash handler-bb + (make-comp-block :sp (1+ (comp-sp))) + blocks) + (comp-mark-block-closed) + (comp-emit-block guarded-bb)))) + (defmacro comp-op-case (&rest cases) "Expand CASES into the corresponding pcase. This is responsible for generating the proper stack adjustment when known and @@ -450,12 +468,12 @@ the annotation emission." op-name)))) (_ (error "Unexpected LAP op %s" (symbol-name op)))))) -(defun comp-limplify-lap-inst (inst) - "Limplify LAP instruction INST pushng it in the proper basic block." - (let ((op (car inst)) - (arg (if (consp (cdr inst)) - (cadr inst) - (cdr inst)))) +(defun comp-limplify-lap-inst (insn) + "Limplify LAP instruction INSN pushng it in the proper basic block." + (let ((op (car insn)) + (arg (if (consp (cdr insn)) + (cadr insn) + (cdr insn)))) (comp-op-case (TAG (comp-emit-block (comp-lap-to-limple-bb arg))) @@ -487,23 +505,9 @@ the annotation emission." (byte-pophandler (comp-emit '(pop-handler))) (byte-pushconditioncase - (let ((blocks (comp-func-blocks comp-func)) - (guarded-bb (comp-new-block-sym))) - (puthash guarded-bb - (make-comp-block :sp (comp-sp)) - blocks) - (let ((handler-bb (comp-lap-to-limple-bb (cl-third inst))) - (handler-type (cdr (last inst)))) - (comp-emit (list 'push-handler (comp-slot-next) - handler-type - handler-bb - guarded-bb)) - (puthash handler-bb - (make-comp-block :sp (1+ (comp-sp))) - blocks) - (comp-mark-block-closed) - (comp-emit-block guarded-bb)))) - (byte-pushcatch) + (comp-emit-handler (cl-third insn) 'condition-case)) + (byte-pushcatch + (comp-emit-handler (cl-third insn) 'catcher)) (byte-nth auto) (byte-symbolp auto) (byte-consp auto) @@ -584,15 +588,15 @@ the annotation emission." (byte-end-of-line auto) (byte-constant2) (byte-goto - (comp-emit-jump (comp-lap-to-limple-bb (cl-third inst)))) + (comp-emit-jump (comp-lap-to-limple-bb (cl-third insn)))) (byte-goto-if-nil - (comp-emit-cond-jump 0 (cl-third inst) nil)) + (comp-emit-cond-jump 0 (cl-third insn) nil)) (byte-goto-if-not-nil - (comp-emit-cond-jump 0 (cl-third inst) t)) + (comp-emit-cond-jump 0 (cl-third insn) t)) (byte-goto-if-nil-else-pop - (comp-emit-cond-jump 1 (cl-third inst) nil)) + (comp-emit-cond-jump 1 (cl-third insn) nil)) (byte-goto-if-not-nil-else-pop - (comp-emit-cond-jump 1 (cl-third inst) t)) + (comp-emit-cond-jump 1 (cl-third insn) t)) (byte-return (comp-emit (list 'return (comp-slot-next))) (comp-mark-block-closed)) diff --git a/src/comp.c b/src/comp.c index 93d0f81dbc..6436a5db71 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1138,10 +1138,17 @@ emit_limple_insn (Lisp_Object insn) { EMACS_UINT clobber_slot = XFIXNUM (FUNCALL1 (comp-mvar-slot, arg0)); gcc_jit_rvalue *handler = emit_mvar_val (arg0); + int h_num; + if (EQ (SECOND (args), Qcatcher)) + h_num = CATCHER; + else if (EQ (SECOND (args), Qcondition_case)) + h_num = CONDITION_CASE; + else + eassert (false); gcc_jit_rvalue *handler_type = gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.int_type, - XFIXNUM (SECOND (args))); + h_num); gcc_jit_block *handler_bb = retrive_block (THIRD (args)); gcc_jit_block *guarded_bb = retrive_block (FORTH (args)); emit_limple_push_handler (handler, handler_type, handler_bb, guarded_bb, @@ -2224,6 +2231,8 @@ syms_of_comp (void) DEFSYM (Qcond_jump, "cond-jump"); DEFSYM (Qpush_handler, "push-handler"); DEFSYM (Qpop_handler, "pop-handler"); + DEFSYM (Qcondition_case, "condition-case"); + DEFSYM (Qcatcher, "catcher"); defsubr (&Scomp_init_ctxt); defsubr (&Scomp_release_ctxt); diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 871dede23a..ed3a9b2f9d 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -448,26 +448,25 @@ (error-message-string err) " catched")))) - ;; (defun comp-tests-catch-f (f) - ;; (catch 'foo - ;; (funcall f))) + (defun comp-tests-catch-f (f) + (catch 'foo + (funcall f))) - ;; (defun comp-tests-throw-f (x) - ;; (throw 'foo x)) + (defun comp-tests-throw-f (x) + (throw 'foo x)) (native-compile #'comp-tests-condition-case-0-f) (native-compile #'comp-tests-condition-case-1-f) - ;; (native-compile #'comp-tests-catch-f) - ;; (native-compile #'comp-tests-throw-f) + (native-compile #'comp-tests-catch-f) + (native-compile #'comp-tests-throw-f) (should (string= (comp-tests-condition-case-0-f) "arith-error Arithmetic error catched")) (should (string= (comp-tests-condition-case-1-f) - "error foo catched"))) - ;; (should (= (comp-tests-catch-f (lambda () (throw 'foo 3))) 3)) - ;; (should (= (catch 'foo - ;; (comp-tests-throw-f 3)))) - ) + "error foo catched")) + (should (= (comp-tests-catch-f (lambda () (throw 'foo 3))) 3)) + (should (= (catch 'foo + (comp-tests-throw-f 3)))))) (ert-deftest comp-tests-gc () "Try to do some longer computation to let the gc kick in." commit 8b22849a5cef3e81e8b81cf7f32c186471607e06 Author: Andrea Corallo Date: Sun Jul 21 22:02:17 2019 +0200 pushconditioncase working diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 558bed3187..35a59dbe60 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -488,21 +488,21 @@ the annotation emission." (comp-emit '(pop-handler))) (byte-pushconditioncase (let ((blocks (comp-func-blocks comp-func)) - (fall-bb (comp-new-block-sym))) ;; Fall through block - (puthash fall-bb + (guarded-bb (comp-new-block-sym))) + (puthash guarded-bb (make-comp-block :sp (comp-sp)) blocks) - (let ((target (comp-lap-to-limple-bb (cl-third inst))) + (let ((handler-bb (comp-lap-to-limple-bb (cl-third inst))) (handler-type (cdr (last inst)))) (comp-emit (list 'push-handler (comp-slot-next) handler-type - target - fall-bb)) - (puthash target - (make-comp-block :sp (comp-sp)) + handler-bb + guarded-bb)) + (puthash handler-bb + (make-comp-block :sp (1+ (comp-sp))) blocks) - (comp-mark-block-closed)) - (comp-emit-block fall-bb))) + (comp-mark-block-closed) + (comp-emit-block guarded-bb)))) (byte-pushcatch) (byte-nth auto) (byte-symbolp auto) @@ -668,9 +668,9 @@ the annotation emission." do (progn (cl-incf (comp-sp)) (comp-emit `(setpar ,(comp-slot) ,i)))) - (comp-emit-jump 'body) + (comp-emit-jump 'bb_1) ;; Body - (comp-emit-block 'body) + (comp-emit-block 'bb_1) (mapc #'comp-limplify-lap-inst (comp-func-lap func)) ;; Reverse insns into all basic blocks. (cl-loop for bb being the hash-value in (comp-func-blocks func) diff --git a/src/comp.c b/src/comp.c index ef72edd499..93d0f81dbc 100644 --- a/src/comp.c +++ b/src/comp.c @@ -948,18 +948,6 @@ emit_PURE_P (gcc_jit_rvalue *ptr) PURESIZE)); } -/* static gcc_jit_rvalue * */ -/* emit_call_n_ref (const char *f_name, unsigned nargs, */ -/* gcc_jit_lvalue *base_arg) */ -/* { */ -/* gcc_jit_rvalue *args[] = */ -/* { gcc_jit_context_new_rvalue_from_int(comp.ctxt, */ -/* comp.ptrdiff_type, */ -/* nargs), */ -/* gcc_jit_lvalue_get_address (base_arg, NULL) }; */ -/* return emit_call (f_name, comp.lisp_obj_type, 2, args); */ -/* } */ - /* Emit an r-value from an mvar meta variable. In case this is a constant that was propagated return it otherwise load it from frame. */ @@ -1051,14 +1039,86 @@ emit_limple_call_ref (Lisp_Object arg1) return emit_call (calle, comp.lisp_obj_type, 2, gcc_args); } +/* Register an handler for a non local exit. */ + +static void +emit_limple_push_handler (gcc_jit_rvalue *handler, gcc_jit_rvalue *handler_type, + gcc_jit_block *handler_bb, gcc_jit_block *guarded_bb, + EMACS_UINT clobber_slot) +{ + /* Ex: (push-handler #s(comp-mvar 6 0 t (arith-error) nil) 1 bb_3 bb_2). */ + + static unsigned pushhandler_n; /* FIXME move at ctxt or func level. */ + gcc_jit_rvalue *args[2]; + + /* struct handler *c = push_handler (POP, type); */ + gcc_jit_lvalue *c = + gcc_jit_function_new_local (comp.func, + NULL, + comp.handler_ptr_type, + format_string ("c_%u", + pushhandler_n)); + args[0] = handler; + args[1] = handler_type; + gcc_jit_block_add_assignment ( + comp.block, + NULL, + c, + emit_call ("push_handler", comp.handler_ptr_type, 2, args)); + + args[0] = + gcc_jit_lvalue_get_address ( + gcc_jit_rvalue_dereference_field ( + gcc_jit_lvalue_as_rvalue (c), + NULL, + comp.handler_jmp_field), + NULL); + + gcc_jit_rvalue *res; +#ifdef HAVE__SETJMP + res = emit_call ("_setjmp", comp.int_type, 1, args); +#else + res = emit_call ("setjmp", comp.int_type, 1, args); +#endif + emit_cond_jump (res, handler_bb, guarded_bb); + + /* This emit the handler part. */ + + comp.block = handler_bb; + gcc_jit_lvalue *m_handlerlist = + gcc_jit_rvalue_dereference_field (comp.current_thread, + NULL, + comp.m_handlerlist); + gcc_jit_block_add_assignment ( + comp.block, + NULL, + m_handlerlist, + gcc_jit_lvalue_as_rvalue( + gcc_jit_rvalue_dereference_field (gcc_jit_lvalue_as_rvalue (c), + NULL, + comp.handler_next_field))); + gcc_jit_block_add_assignment ( + comp.block, + NULL, + comp.frame[clobber_slot], + gcc_jit_lvalue_as_rvalue( + gcc_jit_rvalue_dereference_field (gcc_jit_lvalue_as_rvalue (c), + NULL, + comp.handler_val_field))); + ++pushhandler_n; +} + static void emit_limple_insn (Lisp_Object insn) { Lisp_Object op = XCAR (insn); Lisp_Object args = XCDR (insn); - Lisp_Object arg0 = XCAR (args); + Lisp_Object arg0; gcc_jit_rvalue *res; + if (CONSP (args)) + arg0 = XCAR (args); + if (EQ (op, Qjump)) { /* Unconditional branch. */ @@ -1074,6 +1134,39 @@ emit_limple_insn (Lisp_Object insn) emit_cond_jump (emit_NILP (test), target2, target1); } + else if (EQ (op, Qpush_handler)) + { + EMACS_UINT clobber_slot = XFIXNUM (FUNCALL1 (comp-mvar-slot, arg0)); + gcc_jit_rvalue *handler = emit_mvar_val (arg0); + gcc_jit_rvalue *handler_type = + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.int_type, + XFIXNUM (SECOND (args))); + gcc_jit_block *handler_bb = retrive_block (THIRD (args)); + gcc_jit_block *guarded_bb = retrive_block (FORTH (args)); + emit_limple_push_handler (handler, handler_type, handler_bb, guarded_bb, + clobber_slot); + } + else if (EQ (op, Qpop_handler)) + { + /* current_thread->m_handlerlist = + current_thread->m_handlerlist->next; */ + gcc_jit_lvalue *m_handlerlist = + gcc_jit_rvalue_dereference_field (comp.current_thread, + NULL, + comp.m_handlerlist); + + gcc_jit_block_add_assignment( + comp.block, + NULL, + m_handlerlist, + gcc_jit_lvalue_as_rvalue ( + gcc_jit_rvalue_dereference_field ( + gcc_jit_lvalue_as_rvalue (m_handlerlist), + NULL, + comp.handler_next_field))); + + } else if (EQ (op, Qcall)) { gcc_jit_block_add_eval (comp.block, @@ -2129,6 +2222,8 @@ syms_of_comp (void) DEFSYM (Qreturn, "return"); DEFSYM (Qcomp_mvar, "comp-mvar"); DEFSYM (Qcond_jump, "cond-jump"); + DEFSYM (Qpush_handler, "push-handler"); + DEFSYM (Qpop_handler, "pop-handler"); defsubr (&Scomp_init_ctxt); defsubr (&Scomp_release_ctxt); diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 4462f35246..871dede23a 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -416,56 +416,58 @@ (buffer-string)) "abcd"))) -;; (ert-deftest comp-tests-non-locals () -;; "Test non locals." -;; (defun comp-tests-err-arith-f () -;; (/ 1 0)) -;; (defun comp-tests-err-foo-f () -;; (error "foo")) - -;; (defun comp-tests-condition-case-0-f () -;; ;; Bpushhandler Bpophandler -;; (condition-case -;; err -;; (comp-tests-err-arith-f) -;; (arith-error (concat "arith-error " -;; (error-message-string err) -;; " catched")) -;; (error (concat "error " -;; (error-message-string err) -;; " catched")))) - -;; (defun comp-tests-condition-case-1-f () -;; ;; Bpushhandler Bpophandler -;; (condition-case -;; err -;; (comp-tests-err-foo-f) -;; (arith-error (concat "arith-error " -;; (error-message-string err) -;; " catched")) -;; (error (concat "error " -;; (error-message-string err) -;; " catched")))) - -;; (defun comp-tests-catch-f (f) -;; (catch 'foo -;; (funcall f))) - -;; (defun comp-tests-throw-f (x) -;; (throw 'foo x)) - -;; (native-compile #'comp-tests-condition-case-0-f) -;; (native-compile #'comp-tests-condition-case-1-f) -;; (native-compile #'comp-tests-catch-f) -;; (native-compile #'comp-tests-throw-f) - -;; (should (string= (comp-tests-condition-case-0-f) -;; "arith-error Arithmetic error catched")) -;; (should (string= (comp-tests-condition-case-1-f) -;; "error foo catched")) -;; (should (= (comp-tests-catch-f (lambda () (throw 'foo 3))) 3)) -;; (should (= (catch 'foo -;; (comp-tests-throw-f 3))))) +(ert-deftest comp-tests-non-locals () + "Test non locals." + (let ((gc-cons-threshold most-positive-fixnum)) ;; FIXME!! + (defun comp-tests-err-arith-f () + (/ 1 0)) + (defun comp-tests-err-foo-f () + (error "foo")) + + (defun comp-tests-condition-case-0-f () + ;; Bpushhandler Bpophandler + (condition-case + err + (comp-tests-err-arith-f) + (arith-error (concat "arith-error " + (error-message-string err) + " catched")) + (error (concat "error " + (error-message-string err) + " catched")))) + + (defun comp-tests-condition-case-1-f () + ;; Bpushhandler Bpophandler + (condition-case + err + (comp-tests-err-foo-f) + (arith-error (concat "arith-error " + (error-message-string err) + " catched")) + (error (concat "error " + (error-message-string err) + " catched")))) + + ;; (defun comp-tests-catch-f (f) + ;; (catch 'foo + ;; (funcall f))) + + ;; (defun comp-tests-throw-f (x) + ;; (throw 'foo x)) + + (native-compile #'comp-tests-condition-case-0-f) + (native-compile #'comp-tests-condition-case-1-f) + ;; (native-compile #'comp-tests-catch-f) + ;; (native-compile #'comp-tests-throw-f) + + (should (string= (comp-tests-condition-case-0-f) + "arith-error Arithmetic error catched")) + (should (string= (comp-tests-condition-case-1-f) + "error foo catched"))) + ;; (should (= (comp-tests-catch-f (lambda () (throw 'foo 3))) 3)) + ;; (should (= (catch 'foo + ;; (comp-tests-throw-f 3)))) + ) (ert-deftest comp-tests-gc () "Try to do some longer computation to let the gc kick in." commit 868b6b454ea75361a706ab57b45b6a49b124231d Author: Andrea Corallo Date: Sun Jul 21 15:20:39 2019 +0200 separate basic blocks diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 877111653b..558bed3187 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -41,11 +41,15 @@ (defvar comp-speed 2) (defvar byte-compile-lap-output) -(defconst comp-passes '(comp-recuparate-lap +(defvar comp-pass nil + "Every pass has the right to bind what it likes here.") + +(defconst comp-passes '(comp-spill-lap comp-limplify) "Passes to be executed in order.") -(defconst comp-known-ret-types '((Fcons . cons))) +(defconst comp-known-ret-types '((Fcons . cons)) + "Alist used for type propagation.") (defconst comp-mostly-pure-funcs '(% * + - / /= 1+ 1- < <= = > >= cons list % concat logand logcount logior @@ -70,22 +74,25 @@ (min nil :type number :documentation "Minimum number of arguments allowed.") (max nil - :documentation "Maximum number of arguments allowed -To be used when ncall-conv is nil..") + :documentation "Maximum number of arguments allowed. +To be used when ncall-conv is nil.") (ncall-conv nil :type boolean :documentation "If t the signature is: (ptrdiff_t nargs, Lisp_Object *args).")) (cl-defstruct (comp-block (:copier nil)) "A basic block." + ;; The first two slots are used during limplification. (sp nil - :documentation "When non nil indicates its the sp value while entering + :documentation "When non nil indicates the sp value while entering into it.") (closed nil :type 'boolean - :documentation "If the block was already closed.")) + :documentation "If the block was already closed.") + (insns () :type list + :documentation "List of instructions.")) (cl-defstruct (comp-func (:copier nil)) - "Internal rapresentation for a function." + "LIMPLE representation of a function." (symbol-name nil :documentation "Function symbol's name.") (c-func-name nil :type 'string @@ -94,8 +101,8 @@ into it.") :documentation "Original form.") (byte-func nil :documentation "Byte compiled version.") - (ir nil - :documentation "Current intermediate rappresentation.") + (lap () :type list + :documentation "Lap assembly representation.") (args nil :type 'comp-args) (frame-size nil :type 'number) (blocks (make-hash-table) :type 'hash-table @@ -104,7 +111,7 @@ structure.") (lap-block (make-hash-table :test #'equal) :type 'hash-table :documentation "Key value to convert from LAP label number to LIMPLE basic block.") - (limple-cnt -1 :type 'number + (ssa-cnt -1 :type 'number :documentation "Counter to create ssa limple vars.")) (cl-defstruct (comp-mvar (:copier nil) (:constructor make--comp-mvar)) @@ -121,9 +128,6 @@ LIMPLE basic block.") (type nil :documentation "When non nil is used for type propagation.")) - -;;; Limplification pass specific code. - (cl-defstruct (comp-limplify (:copier nil)) "Support structure used during limplification." (sp 0 :type 'fixnum @@ -133,17 +137,22 @@ LIMPLE basic block.") (block-name nil :type 'symbol :documentation "Current basic block name.")) -(defun comp-new-frame (size) - "Return a clean frame of meta variables of size SIZE." - (let ((v (make-vector size nil))) - (cl-loop for i below size - do (aset v i (make-comp-mvar :slot i))) - v)) +(defun comp-pretty-print-func (func) + "Pretty print function FUNC in the current buffer." + (insert (format "\n\n Function: %s" (comp-func-symbol-name func))) + (cl-loop for bb being each hash-values of (comp-func-blocks func) + using (hash-key block-name) + do (progn + (insert (concat "\n<" (symbol-name block-name) ">")) + (cl-prettyprint (comp-block-insns bb))))) + + +;;; spill-lap pass specific code. (defun comp-c-func-name (symbol-function) "Given SYMBOL-FUNCTION return a name suitable for the native code." ;; Unfortunatelly not all symbol names are valid as C function names... - ;; Nassi's algorithm. + ;; Nassi's algorithm here: (let* ((orig-name (symbol-name symbol-function)) (crypted (cl-loop with str = (make-string (* 2 (length orig-name)) 0) for j from 0 by 2 @@ -170,26 +179,28 @@ LIMPLE basic block.") (make-comp-args :min mandatory :ncall-conv t)))) -(defun comp-recuparate-lap (func) - "Byte compile and recuparate LAP rapresentation for FUNC." - ;; FIXME block timers here, otherwise we could spill the wrong LAP. - (setf (comp-func-byte-func func) - (byte-compile (comp-func-symbol-name func))) - (when comp-debug - (cl-prettyprint byte-compile-lap-output)) - (let ((lambda-list (aref (comp-func-byte-func func) 0))) - (if (fixnump lambda-list) - (setf (comp-func-args func) - (comp-decrypt-lambda-list (aref (comp-func-byte-func func) 0))) - (error "Can't native compile a non lexical scoped function"))) - (setf (comp-func-ir func) byte-compile-lap-output) - (setf (comp-func-frame-size func) (aref (comp-func-byte-func func) 3)) - func) +(defun comp-spill-lap (func) + "Byte compile and spill the LAP rapresentation for FUNC." + (let (byte-compile-lap-output) + (setf (comp-func-byte-func func) + (byte-compile (comp-func-symbol-name func))) + (when comp-debug + (cl-prettyprint byte-compile-lap-output)) + (let ((lambda-list (aref (comp-func-byte-func func) 0))) + (if (fixnump lambda-list) + (setf (comp-func-args func) + (comp-decrypt-lambda-list (aref (comp-func-byte-func func) 0))) + (error "Can't native compile a non lexical scoped function"))) + (setf (comp-func-lap func) byte-compile-lap-output) + (setf (comp-func-frame-size func) (aref (comp-func-byte-func func) 3)) + func)) -(declare-function comp-init-ctxt "comp.c") -(declare-function comp-release-ctxt "comp.c") -(declare-function comp-add-func-to-ctxt "comp.c") -(declare-function comp-compile-and-load-ctxt "comp.c") + +;;; Limplification pass specific code. + +;; Special vars used during limplifications +(defvar comp-block) +(defvar comp-func) ;; (defun comp-opt-call (inst) ;; "Optimize if possible a side-effect-free call in INST." @@ -198,13 +209,15 @@ LIMPLE basic block.") ;; (cl-every #'identity (mapcar #'comp-mvar-const-vld args))) ;; (apply f (mapcar #'comp-mvar-constant args))))) -;; Special vars used during limplifications -(defvar comp-pass) -(defvar comp-limple) -(defvar comp-func) +(defun comp-new-frame (size) + "Return a clean frame of meta variables of size SIZE." + (let ((v (make-vector size nil))) + (cl-loop for i below size + do (aset v i (make-comp-mvar :slot i))) + v)) (cl-defun make-comp-mvar (&key slot const-vld constant type) - (make--comp-mvar :id (cl-incf (comp-func-limple-cnt comp-func)) + (make--comp-mvar :id (cl-incf (comp-func-ssa-cnt comp-func)) :slot slot :const-vld const-vld :constant constant :type type)) @@ -236,9 +249,9 @@ Restore the original value afterwards." "Slot into the meta-stack pointed by sp + 1." '(comp-slot-n (1+ (comp-sp)))) -(defun comp-emit (x) - "Emit X into current LIMPLE ir.." - (push x comp-limple)) +(defun comp-emit (insn) + "Emit INSN into current basic block." + (push insn (comp-block-insns comp-block))) (defun comp-emit-set-call (call) "Emit CALL assigning the result the the current slot frame. @@ -328,9 +341,12 @@ If DST-N is specified use it otherwise assume it to be the current slot." ;; If we are abandoning an non closed basic block close it with a fall ;; through. (when (and (not (eq block-name 'entry)) - (not (comp-block-closed (gethash (comp-limplify-block-name comp-pass) - blocks)))) + (not (comp-block-closed + (gethash (comp-limplify-block-name comp-pass) + blocks)))) (comp-emit-jump block-name)) + ;; Set this a currently compiled block. + (setf comp-block (gethash block-name blocks)) ;; Every new block we are forced to wipe out all the frame. ;; This will be optimized by proper flow analysis. (setf (comp-limplify-frame comp-pass) @@ -338,7 +354,6 @@ If DST-N is specified use it otherwise assume it to be the current slot." ;; If we are landing here form a recorded branch adjust sp accordingly. (setf (comp-sp) (comp-block-sp (gethash block-name blocks))) - (comp-emit `(block ,block-name)) (setf (comp-limplify-block-name comp-pass) block-name))) (defun comp-emit-cond-jump (target-offset lap-label negated) @@ -436,7 +451,7 @@ the annotation emission." (_ (error "Unexpected LAP op %s" (symbol-name op)))))) (defun comp-limplify-lap-inst (inst) - "Limplify LAP instruction INST accumulating in `comp-limple'." + "Limplify LAP instruction INST pushng it in the proper basic block." (let ((op (car inst)) (arg (if (consp (cdr inst)) (cadr inst) @@ -644,7 +659,7 @@ the annotation emission." (comp-pass (make-comp-limplify :sp -1 :frame (comp-new-frame frame-size))) - (comp-limple ())) + (comp-block ())) ;; Prologue (comp-emit-block 'entry) (comp-emit-annotation (concat "Lisp function: " @@ -652,28 +667,37 @@ the annotation emission." (cl-loop for i below (comp-args-min (comp-func-args func)) do (progn (cl-incf (comp-sp)) - (push `(setpar ,(comp-slot) ,i) comp-limple))) + (comp-emit `(setpar ,(comp-slot) ,i)))) (comp-emit-jump 'body) ;; Body (comp-emit-block 'body) - (mapc #'comp-limplify-lap-inst (comp-func-ir func)) - (setf (comp-func-ir func) (reverse comp-limple)) + (mapc #'comp-limplify-lap-inst (comp-func-lap func)) + ;; Reverse insns into all basic blocks. + (cl-loop for bb being the hash-value in (comp-func-blocks func) + do (setf (comp-block-insns bb) + (reverse (comp-block-insns bb)))) (when comp-debug - (cl-prettyprint (comp-func-ir func))) + (comp-pretty-print-func func)) func)) ;;; Entry points. -(defun native-compile (fun) - "FUN is the function definition to be compiled into native code." - (if-let ((f (symbol-function fun))) +(declare-function comp-init-ctxt "comp.c") +(declare-function comp-release-ctxt "comp.c") +(declare-function comp-add-func-to-ctxt "comp.c") +(declare-function comp-compile-and-load-ctxt "comp.c") + +(defun native-compile (func-symbol-name) + "FUNC-SYMBOL-NAME is the function name to be compiled into native code." + (if-let ((f (symbol-function func-symbol-name))) (progn (when (byte-code-function-p f) (error "Can't native compile an already bytecompiled function")) - (let ((func (make-comp-func :symbol-name fun + (let ((func (make-comp-func :symbol-name func-symbol-name :func f - :c-func-name (comp-c-func-name fun)))) + :c-func-name (comp-c-func-name + func-symbol-name)))) (mapc (lambda (pass) (funcall pass func)) comp-passes) diff --git a/src/comp.c b/src/comp.c index edc35cf8b0..ef72edd499 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1052,19 +1052,14 @@ emit_limple_call_ref (Lisp_Object arg1) } static void -emit_limple_inst (Lisp_Object inst) +emit_limple_insn (Lisp_Object insn) { - Lisp_Object op = XCAR (inst); - Lisp_Object args = XCDR (inst); + Lisp_Object op = XCAR (insn); + Lisp_Object args = XCDR (insn); Lisp_Object arg0 = XCAR (args); gcc_jit_rvalue *res; - if (EQ (op, Qblock)) - { - /* Search for the already defined block and make it current. */ - comp.block = retrive_block (arg0); - } - else if (EQ (op, Qjump)) + if (EQ (op, Qjump)) { /* Unconditional branch. */ gcc_jit_block *target = retrive_block (arg0); @@ -1083,7 +1078,7 @@ emit_limple_inst (Lisp_Object inst) { gcc_jit_block_add_eval (comp.block, NULL, - emit_limple_call (inst)); + emit_limple_call (insn)); } else if (EQ (op, Qset)) { @@ -2052,20 +2047,19 @@ DEFUN ("comp-add-func-to-ctxt", Fcomp_add_func_to_ctxt, Scomp_add_func_to_ctxt, declare_block ((char *) SDATA (SYMBOL_NAME (HASH_KEY (ht, i)))); } - while (CONSP (blocks)) + for (ptrdiff_t i = 0; i < ht->count; i++) { - char *block_name = (char *) SDATA (SYMBOL_NAME (XCAR (blocks))); - declare_block (block_name); - blocks = XCDR (blocks); - } - - Lisp_Object limple = FUNCALL1 (comp-func-ir, func); + Lisp_Object block_name = HASH_KEY (ht, i); + Lisp_Object block = HASH_VALUE (ht, i); + Lisp_Object insns = FUNCALL1 (comp-block-insns, block); - while (CONSP (limple)) - { - Lisp_Object inst = XCAR (limple); - emit_limple_inst (inst); - limple = XCDR (limple); + comp.block = retrive_block (block_name); + while (CONSP (insns)) + { + Lisp_Object insn = XCAR (insns); + emit_limple_insn (insn); + insns = XCDR (insns); + } } comp.funcs = Fcons (func, comp.funcs); @@ -2126,7 +2120,6 @@ syms_of_comp (void) { /* Limple instruction set. */ DEFSYM (Qcomment, "comment"); - DEFSYM (Qblock, "block"); DEFSYM (Qjump, "jump"); DEFSYM (Qcall, "call"); DEFSYM (Qcallref, "callref"); commit a2cf65d2030c7856d029e43fec378efe42934400 Author: Andrea Corallo Date: Sun Jul 21 13:57:51 2019 +0200 separate code diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 62b80a0a5a..877111653b 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -121,6 +121,9 @@ LIMPLE basic block.") (type nil :documentation "When non nil is used for type propagation.")) + +;;; Limplification pass specific code. + (cl-defstruct (comp-limplify (:copier nil)) "Support structure used during limplification." (sp 0 :type 'fixnum @@ -659,6 +662,9 @@ the annotation emission." (cl-prettyprint (comp-func-ir func))) func)) + +;;; Entry points. + (defun native-compile (fun) "FUN is the function definition to be compiled into native code." (if-let ((f (symbol-function fun))) commit 976357769fe33e36afb37d5cd663587f46e88d0e Author: Andrea Corallo Date: Sun Jul 21 12:11:45 2019 +0200 rework arg parsing on the C side diff --git a/src/comp.c b/src/comp.c index 152a0e6180..edc35cf8b0 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1055,7 +1055,8 @@ static void emit_limple_inst (Lisp_Object inst) { Lisp_Object op = XCAR (inst); - Lisp_Object arg0 = SECOND (inst); + Lisp_Object args = XCDR (inst); + Lisp_Object arg0 = XCAR (args); gcc_jit_rvalue *res; if (EQ (op, Qblock)) @@ -1071,10 +1072,10 @@ emit_limple_inst (Lisp_Object inst) } else if (EQ (op, Qcond_jump)) { - /* Conditional branch. */ + /* Conditional branch. */ gcc_jit_rvalue *test = emit_mvar_val (arg0); - gcc_jit_block *target1 = retrive_block (THIRD (inst)); - gcc_jit_block *target2 = retrive_block (FORTH (inst)); + gcc_jit_block *target1 = retrive_block (SECOND (args)); + gcc_jit_block *target2 = retrive_block (THIRD (args)); emit_cond_jump (emit_NILP (test), target2, target1); } @@ -1087,7 +1088,7 @@ emit_limple_inst (Lisp_Object inst) else if (EQ (op, Qset)) { EMACS_UINT slot_n = XFIXNUM (FUNCALL1 (comp-mvar-slot, arg0)); - Lisp_Object arg1 = THIRD (inst); + Lisp_Object arg1 = SECOND (args); if (EQ (Ftype_of (arg1), Qcomp_mvar)) res = emit_mvar_val (arg1); @@ -1107,7 +1108,7 @@ emit_limple_inst (Lisp_Object inst) { /* Ex: (=par #s(comp-mvar 2 0 nil nil nil) 0). */ EMACS_UINT slot_n = XFIXNUM (FUNCALL1 (comp-mvar-slot, arg0)); - EMACS_UINT param_n = XFIXNUM (THIRD (inst)); + EMACS_UINT param_n = XFIXNUM (SECOND (args)); gcc_jit_rvalue *param = gcc_jit_param_as_rvalue (gcc_jit_function_get_param (comp.func, param_n)); @@ -1119,7 +1120,7 @@ emit_limple_inst (Lisp_Object inst) else if (EQ (op, Qsetimm)) { /* EX: (=imm #s(comp-mvar 9 1 t 3 nil) 3). */ - Lisp_Object arg1 = THIRD (inst); + Lisp_Object arg1 = SECOND (args); EMACS_UINT slot_n = XFIXNUM (FUNCALL1 (comp-mvar-slot, arg0)); gcc_jit_block_add_assignment (comp.block, NULL, commit 759a15d446b7f728d2d146cb1bfd6d722df9e998 Author: Andrea Corallo Date: Sun Jul 21 11:38:26 2019 +0200 adding non locals diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index a3c2db4283..62b80a0a5a 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -466,8 +466,25 @@ the annotation emission." :constant arg) ,(make-comp-mvar :const-vld t :constant nil)))) - (byte-pophandler) - (byte-pushconditioncase) + (byte-pophandler + (comp-emit '(pop-handler))) + (byte-pushconditioncase + (let ((blocks (comp-func-blocks comp-func)) + (fall-bb (comp-new-block-sym))) ;; Fall through block + (puthash fall-bb + (make-comp-block :sp (comp-sp)) + blocks) + (let ((target (comp-lap-to-limple-bb (cl-third inst))) + (handler-type (cdr (last inst)))) + (comp-emit (list 'push-handler (comp-slot-next) + handler-type + target + fall-bb)) + (puthash target + (make-comp-block :sp (comp-sp)) + blocks) + (comp-mark-block-closed)) + (comp-emit-block fall-bb))) (byte-pushcatch) (byte-nth auto) (byte-symbolp auto) commit 7726cb254503c2c3d082ffb8aed9c12cbeeec12e Author: Andrea Corallo Date: Sun Jul 21 09:50:18 2019 +0200 bubble sort works again diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index e2a9b1ce49..4462f35246 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -334,26 +334,26 @@ (error err)) '(wrong-type-argument consp 3)))) -;; (ert-deftest comp-tests-bubble-sort () -;; "Run bubble sort." -;; (defun comp-bubble-sort-f (list) -;; (let ((i (length list))) -;; (while (> i 1) -;; (let ((b list)) -;; (while (cdr b) -;; (when (< (cadr b) (car b)) -;; (setcar b (prog1 (cadr b) -;; (setcdr b (cons (car b) (cddr b)))))) -;; (setq b (cdr b)))) -;; (setq i (1- i))) -;; list)) - -;; (native-compile #'comp-bubble-sort-f) - -;; (let* ((list1 (mapcar 'random (make-list 1000 most-positive-fixnum))) -;; (list2 (copy-sequence list1))) -;; (should (equal (comp-bubble-sort-f list1) -;; (sort list2 #'<))))) +(ert-deftest comp-tests-bubble-sort () + "Run bubble sort." + (defun comp-bubble-sort-f (list) + (let ((i (length list))) + (while (> i 1) + (let ((b list)) + (while (cdr b) + (when (< (cadr b) (car b)) + (setcar b (prog1 (cadr b) + (setcdr b (cons (car b) (cddr b)))))) + (setq b (cdr b)))) + (setq i (1- i))) + list)) + + (native-compile #'comp-bubble-sort-f) + + (let* ((list1 (mapcar 'random (make-list 1000 most-positive-fixnum))) + (list2 (copy-sequence list1))) + (should (equal (comp-bubble-sort-f list1) + (sort list2 #'<))))) (ert-deftest comp-tests-list-inline () "Test some inlined list functions." commit e25cf441152746a4686ab7adca8d3302e0740189 Author: Andrea Corallo Date: Sun Jul 21 09:48:52 2019 +0200 fix comp-emit-cond-jump diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 8b3c3d2062..a3c2db4283 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -338,24 +338,24 @@ If DST-N is specified use it otherwise assume it to be the current slot." (comp-emit `(block ,block-name)) (setf (comp-limplify-block-name comp-pass) block-name))) -(defun comp-emit-cond-jump (discard-n lap-label negated) +(defun comp-emit-cond-jump (target-offset lap-label negated) "Emit a conditional jump to LAP-LABEL. -Discard DISCARD-N slots afterward. +TARGET-OFFSET is the positive offset on the SP when branching to the target +block. If NEGATED non nil negate the test condition." - (let ((bb (comp-new-block-sym)) - (blocks (comp-func-blocks comp-func))) + (let ((blocks (comp-func-blocks comp-func)) + (bb (comp-new-block-sym))) ;; Fall through block (puthash bb - (make-comp-block :sp (- (comp-sp) discard-n)) + (make-comp-block :sp (comp-sp)) blocks) - (progn - (let ((target (comp-lap-to-limple-bb lap-label))) - (comp-emit (if negated - (list 'cond-jump (comp-slot-next) target bb) - (list 'cond-jump (comp-slot-next) bb target))) - (puthash target - (make-comp-block :sp (comp-sp)) - blocks) - (comp-mark-block-closed))) + (let ((target (comp-lap-to-limple-bb lap-label))) + (comp-emit (if negated + (list 'cond-jump (comp-slot-next) target bb) + (list 'cond-jump (comp-slot-next) bb target))) + (puthash target + (make-comp-block :sp (+ target-offset (comp-sp))) + blocks) + (comp-mark-block-closed)) (comp-emit-block bb))) (defun comp-stack-adjust (n) commit 6e1e1bdc2c6ee45ac12283f8e8096723d60d93a1 Author: Andrea Corallo Date: Sat Jul 20 19:56:54 2019 +0200 fix goto diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 9151c304a1..8b3c3d2062 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -549,15 +549,7 @@ the annotation emission." (byte-end-of-line auto) (byte-constant2) (byte-goto - (let ((bb (comp-new-block-sym)) - (blocks (comp-func-blocks comp-func)) - (target (comp-lap-to-limple-bb (cl-third inst)))) - (puthash bb (make-comp-block :sp (comp-sp)) blocks) - (comp-emit-jump target) - (puthash target - (make-comp-block :sp (comp-sp)) - blocks) - (comp-emit-block bb))) + (comp-emit-jump (comp-lap-to-limple-bb (cl-third inst)))) (byte-goto-if-nil (comp-emit-cond-jump 0 (cl-third inst) nil)) (byte-goto-if-not-nil commit d025ce26f849ae8429f5250eeaf6f4915befe804 Author: Andrea Corallo Date: Sat Jul 20 19:26:30 2019 +0200 stackset diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 91aad45bc6..9151c304a1 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -280,15 +280,17 @@ If C-FUN-NAME is nil it will be guessed from SUBR-NAME." collect (comp-slot-n (+ i (comp-sp)))))) (comp-emit-set-call `(call ,c-fun-name ,@slots))))))) -(defun comp-copy-slot-n (n) - "Set current slot with slot number N as source." - (let ((src-slot (comp-slot-n n))) - (cl-assert src-slot) - ;; FIXME id should encrease here. - (setf (comp-slot) - (copy-sequence src-slot)) - (setf (comp-mvar-slot (comp-slot)) (comp-sp)) - (comp-emit (list 'set (comp-slot) src-slot)))) +(defun comp-copy-slot (src-n &optional dst-n) + "Set slot number DST-N to slot number SRC-N as source. +If DST-N is specified use it otherwise assume it to be the current slot." + (comp-with-sp (if dst-n dst-n (comp-sp)) + (let ((src-slot (comp-slot-n src-n))) + (cl-assert src-slot) + ;; FIXME id should encrease here. + (setf (comp-slot) + (copy-sequence src-slot)) + (setf (comp-mvar-slot (comp-slot)) (comp-sp)) + (comp-emit (list 'set (comp-slot) src-slot))))) (defun comp-emit-annotation (str) "Emit annotation STR." @@ -440,7 +442,7 @@ the annotation emission." (TAG (comp-emit-block (comp-lap-to-limple-bb arg))) (byte-stack-ref - (comp-copy-slot-n (- (comp-sp) (cdr inst) 1))) + (comp-copy-slot (- (comp-sp) arg 1))) (byte-varref (comp-emit-set-call `(call Fsymbol_value ,(make-comp-mvar :const-vld t @@ -569,7 +571,7 @@ the annotation emission." (comp-mark-block-closed)) (byte-discard 'pass) (byte-dup - (comp-copy-slot-n (1- (comp-sp)))) + (comp-copy-slot (1- (comp-sp)))) (byte-save-excursion) (byte-save-window-excursion-OBSOLETE) (byte-save-restriction) @@ -602,23 +604,26 @@ the annotation emission." (byte-numberp auto) (byte-integerp auto) (byte-listN - (comp-stack-adjust (- (1- arg))) + (comp-stack-adjust (- 1 arg)) (comp-emit-set-call `(callref Flist ,arg ,(comp-sp)))) (byte-concatN - (comp-stack-adjust (- (1- arg))) + (comp-stack-adjust (- 1 arg)) (comp-emit-set-call `(callref Fconcat ,arg ,(comp-sp)))) (byte-insertN - (comp-stack-adjust (- (1- arg))) + (comp-stack-adjust (- 1 arg)) (comp-emit-set-call `(callref Finsert ,arg ,(comp-sp)))) - (byte-stack-set) + (byte-stack-set + (comp-with-sp (1+ (comp-sp)) + (comp-copy-slot (comp-sp) (- (comp-sp) arg)))) (byte-stack-set2) - (byte-discardN) + (byte-discardN + (comp-stack-adjust (- arg))) (byte-switch) (byte-constant (comp-emit-set-const arg)) (byte-discardN-preserve-tos (comp-stack-adjust (- arg)) - (comp-copy-slot-n (+ arg (comp-sp))))))) + (comp-copy-slot (+ arg (comp-sp))))))) (defun comp-limplify (func) "Given FUNC compute its LIMPLE ir." commit 80826b8220c6f26609ce916ceee3a0bd143a1b41 Author: Andrea Corallo Date: Sat Jul 20 18:50:52 2019 +0200 uncomment test diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 938bf53c01..e2a9b1ce49 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -394,27 +394,27 @@ (should (eq (comp-tests-numberp-f 'a) nil)) (should (eq (comp-tests-numberp-f 3.5) t))) -;; (ert-deftest comp-tests-stack () -;; "Test some stack operation." -;; (defun comp-tests-discardn-f (x) -;; ;; BdiscardN -;; (1+ (let ((a 1) -;; (_b) -;; (_c)) -;; a))) -;; (defun comp-tests-insertn-f (a b c d) -;; ;; Binsert -;; (insert a b c d)) - -;; (native-compile #'comp-tests-discardn-f) -;; (native-compile #'comp-tests-insertn-f) - -;; (should (= (comp-tests-discardn-f 10) 2)) - -;; (should (string= (with-temp-buffer -;; (comp-tests-insertn-f "a" "b" "c" "d") -;; (buffer-string)) -;; "abcd"))) +(ert-deftest comp-tests-stack () + "Test some stack operation." + (defun comp-tests-discardn-f (x) + ;; BdiscardN + (1+ (let ((a 1) + (_b) + (_c)) + a))) + (defun comp-tests-insertn-f (a b c d) + ;; Binsert + (insert a b c d)) + + (native-compile #'comp-tests-discardn-f) + (native-compile #'comp-tests-insertn-f) + + (should (= (comp-tests-discardn-f 10) 2)) + + (should (string= (with-temp-buffer + (comp-tests-insertn-f "a" "b" "c" "d") + (buffer-string)) + "abcd"))) ;; (ert-deftest comp-tests-non-locals () ;; "Test non locals." commit 8da012e224276e42c15d613c0aac3ce3e1a3d939 Author: Andrea Corallo Date: Sat Jul 20 18:50:41 2019 +0200 ops diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index cdbae34387..91aad45bc6 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -601,17 +601,24 @@ the annotation emission." (byte-rem % Frem) (byte-numberp auto) (byte-integerp auto) - (byte-listN) + (byte-listN + (comp-stack-adjust (- (1- arg))) + (comp-emit-set-call `(callref Flist ,arg ,(comp-sp)))) (byte-concatN (comp-stack-adjust (- (1- arg))) (comp-emit-set-call `(callref Fconcat ,arg ,(comp-sp)))) - (byte-insertN) + (byte-insertN + (comp-stack-adjust (- (1- arg))) + (comp-emit-set-call `(callref Finsert ,arg ,(comp-sp)))) (byte-stack-set) (byte-stack-set2) (byte-discardN) (byte-switch) (byte-constant - (comp-emit-set-const arg))))) + (comp-emit-set-const arg)) + (byte-discardN-preserve-tos + (comp-stack-adjust (- arg)) + (comp-copy-slot-n (+ arg (comp-sp))))))) (defun comp-limplify (func) "Given FUNC compute its LIMPLE ir." commit 13651c52ca6c90265fe568a62db1f81152cfbfa7 Author: Andrea Corallo Date: Sat Jul 20 17:50:51 2019 +0200 uncommenting some test diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index d11cf8657c..938bf53c01 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -230,109 +230,109 @@ (should (= (comp-tests-conditionals-2-f t) 1340)) (should (eq (comp-tests-conditionals-2-f nil) nil))) -;; (ert-deftest comp-tests-fixnum () -;; "Testing some fixnum inline operation." -;; (defun comp-tests-fixnum-1-minus-f (x) -;; ;; Bsub1 -;; (1- x)) -;; (defun comp-tests-fixnum-1-plus-f (x) -;; ;; Badd1 -;; (1+ x)) -;; (defun comp-tests-fixnum-minus-f (x) -;; ;; Bnegate -;; (- x)) - -;; (native-compile #'comp-tests-fixnum-1-minus-f) -;; (native-compile #'comp-tests-fixnum-1-plus-f) -;; (native-compile #'comp-tests-fixnum-minus-f) - -;; (should (= (comp-tests-fixnum-1-minus-f 10) 9)) -;; (should (= (comp-tests-fixnum-1-minus-f most-negative-fixnum) -;; (1- most-negative-fixnum))) -;; (should (equal (condition-case err -;; (comp-tests-fixnum-1-minus-f 'a) -;; (error err)) -;; '(wrong-type-argument number-or-marker-p a))) -;; (should (= (comp-tests-fixnum-1-plus-f 10) 11)) -;; (should (= (comp-tests-fixnum-1-plus-f most-positive-fixnum) -;; (1+ most-positive-fixnum))) -;; (should (equal (condition-case err -;; (comp-tests-fixnum-1-plus-f 'a) -;; (error err)) -;; '(wrong-type-argument number-or-marker-p a))) -;; (should (= (comp-tests-fixnum-minus-f 10) -10)) -;; (should (= (comp-tests-fixnum-minus-f most-negative-fixnum) -;; (- most-negative-fixnum))) -;; (should (equal (condition-case err -;; (comp-tests-fixnum-minus-f 'a) -;; (error err)) -;; '(wrong-type-argument number-or-marker-p a)))) - -;; (ert-deftest comp-tests-arith-comp () -;; "Testing arithmetic comparisons." -;; (defun comp-tests-eqlsign-f (x y) -;; ;; Beqlsign -;; (= x y)) -;; (defun comp-tests-gtr-f (x y) -;; ;; Bgtr -;; (> x y)) -;; (defun comp-tests-lss-f (x y) -;; ;; Blss -;; (< x y)) -;; (defun comp-tests-les-f (x y) -;; ;; Bleq -;; (<= x y)) -;; (defun comp-tests-geq-f (x y) -;; ;; Bgeq -;; (>= x y)) - - -;; (native-compile #'comp-tests-eqlsign-f) -;; (native-compile #'comp-tests-gtr-f) -;; (native-compile #'comp-tests-lss-f) -;; (native-compile #'comp-tests-les-f) -;; (native-compile #'comp-tests-geq-f) - -;; (should (eq (comp-tests-eqlsign-f 4 3) nil)) -;; (should (eq (comp-tests-eqlsign-f 3 3) t)) -;; (should (eq (comp-tests-eqlsign-f 2 3) nil)) -;; (should (eq (comp-tests-gtr-f 4 3) t)) -;; (should (eq (comp-tests-gtr-f 3 3) nil)) -;; (should (eq (comp-tests-gtr-f 2 3) nil)) -;; (should (eq (comp-tests-lss-f 4 3) nil)) -;; (should (eq (comp-tests-lss-f 3 3) nil)) -;; (should (eq (comp-tests-lss-f 2 3) t)) -;; (should (eq (comp-tests-les-f 4 3) nil)) -;; (should (eq (comp-tests-les-f 3 3) t)) -;; (should (eq (comp-tests-les-f 2 3) t)) -;; (should (eq (comp-tests-geq-f 4 3) t)) -;; (should (eq (comp-tests-geq-f 3 3) t)) -;; (should (eq (comp-tests-geq-f 2 3) nil))) - -;; (ert-deftest comp-tests-setcarcdr () -;; "Testing setcar setcdr." -;; (defun comp-tests-setcar-f (x y) -;; (setcar x y) -;; x) -;; (defun comp-tests-setcdr-f (x y) -;; (setcdr x y) -;; x) - -;; (native-compile #'comp-tests-setcar-f) -;; (native-compile #'comp-tests-setcdr-f) - -;; (should (equal (comp-tests-setcar-f '(10 . 10) 3) '(3 . 10))) -;; (should (equal (comp-tests-setcdr-f '(10 . 10) 3) '(10 . 3))) -;; (should (equal (condition-case -;; err -;; (comp-tests-setcar-f 3 10) -;; (error err)) -;; '(wrong-type-argument consp 3))) -;; (should (equal (condition-case -;; err -;; (comp-tests-setcdr-f 3 10) -;; (error err)) -;; '(wrong-type-argument consp 3)))) +(ert-deftest comp-tests-fixnum () + "Testing some fixnum inline operation." + (defun comp-tests-fixnum-1-minus-f (x) + ;; Bsub1 + (1- x)) + (defun comp-tests-fixnum-1-plus-f (x) + ;; Badd1 + (1+ x)) + (defun comp-tests-fixnum-minus-f (x) + ;; Bnegate + (- x)) + + (native-compile #'comp-tests-fixnum-1-minus-f) + (native-compile #'comp-tests-fixnum-1-plus-f) + (native-compile #'comp-tests-fixnum-minus-f) + + (should (= (comp-tests-fixnum-1-minus-f 10) 9)) + (should (= (comp-tests-fixnum-1-minus-f most-negative-fixnum) + (1- most-negative-fixnum))) + (should (equal (condition-case err + (comp-tests-fixnum-1-minus-f 'a) + (error err)) + '(wrong-type-argument number-or-marker-p a))) + (should (= (comp-tests-fixnum-1-plus-f 10) 11)) + (should (= (comp-tests-fixnum-1-plus-f most-positive-fixnum) + (1+ most-positive-fixnum))) + (should (equal (condition-case err + (comp-tests-fixnum-1-plus-f 'a) + (error err)) + '(wrong-type-argument number-or-marker-p a))) + (should (= (comp-tests-fixnum-minus-f 10) -10)) + (should (= (comp-tests-fixnum-minus-f most-negative-fixnum) + (- most-negative-fixnum))) + (should (equal (condition-case err + (comp-tests-fixnum-minus-f 'a) + (error err)) + '(wrong-type-argument number-or-marker-p a)))) + +(ert-deftest comp-tests-arith-comp () + "Testing arithmetic comparisons." + (defun comp-tests-eqlsign-f (x y) + ;; Beqlsign + (= x y)) + (defun comp-tests-gtr-f (x y) + ;; Bgtr + (> x y)) + (defun comp-tests-lss-f (x y) + ;; Blss + (< x y)) + (defun comp-tests-les-f (x y) + ;; Bleq + (<= x y)) + (defun comp-tests-geq-f (x y) + ;; Bgeq + (>= x y)) + + + (native-compile #'comp-tests-eqlsign-f) + (native-compile #'comp-tests-gtr-f) + (native-compile #'comp-tests-lss-f) + (native-compile #'comp-tests-les-f) + (native-compile #'comp-tests-geq-f) + + (should (eq (comp-tests-eqlsign-f 4 3) nil)) + (should (eq (comp-tests-eqlsign-f 3 3) t)) + (should (eq (comp-tests-eqlsign-f 2 3) nil)) + (should (eq (comp-tests-gtr-f 4 3) t)) + (should (eq (comp-tests-gtr-f 3 3) nil)) + (should (eq (comp-tests-gtr-f 2 3) nil)) + (should (eq (comp-tests-lss-f 4 3) nil)) + (should (eq (comp-tests-lss-f 3 3) nil)) + (should (eq (comp-tests-lss-f 2 3) t)) + (should (eq (comp-tests-les-f 4 3) nil)) + (should (eq (comp-tests-les-f 3 3) t)) + (should (eq (comp-tests-les-f 2 3) t)) + (should (eq (comp-tests-geq-f 4 3) t)) + (should (eq (comp-tests-geq-f 3 3) t)) + (should (eq (comp-tests-geq-f 2 3) nil))) + +(ert-deftest comp-tests-setcarcdr () + "Testing setcar setcdr." + (defun comp-tests-setcar-f (x y) + (setcar x y) + x) + (defun comp-tests-setcdr-f (x y) + (setcdr x y) + x) + + (native-compile #'comp-tests-setcar-f) + (native-compile #'comp-tests-setcdr-f) + + (should (equal (comp-tests-setcar-f '(10 . 10) 3) '(3 . 10))) + (should (equal (comp-tests-setcdr-f '(10 . 10) 3) '(10 . 3))) + (should (equal (condition-case + err + (comp-tests-setcar-f 3 10) + (error err)) + '(wrong-type-argument consp 3))) + (should (equal (condition-case + err + (comp-tests-setcdr-f 3 10) + (error err)) + '(wrong-type-argument consp 3)))) ;; (ert-deftest comp-tests-bubble-sort () ;; "Run bubble sort." @@ -355,44 +355,44 @@ ;; (should (equal (comp-bubble-sort-f list1) ;; (sort list2 #'<))))) -;; (ert-deftest comp-tests-list-inline () -;; "Test some inlined list functions." -;; (defun comp-tests-consp-f (x) -;; ;; Bconsp -;; (consp x)) -;; (defun comp-tests-car-f (x) -;; ;; Bsetcar -;; (setcar x 3)) - -;; (native-compile #'comp-tests-consp-f) -;; (native-compile #'comp-tests-car-f) - -;; (should (eq (comp-tests-consp-f '(1)) t)) -;; (should (eq (comp-tests-consp-f 1) nil)) -;; (let ((x (cons 1 2))) -;; (should (= (comp-tests-car-f x) 3)) -;; (should (equal x '(3 . 2))))) - -;; (ert-deftest comp-tests-num-inline () -;; "Test some inlined number functions." -;; (defun comp-tests-integerp-f (x) -;; ;; Bintegerp -;; (integerp x)) -;; (defun comp-tests-numberp-f (x) -;; ;; Bnumberp -;; (numberp x)) - -;; (native-compile #'comp-tests-integerp-f) -;; (native-compile #'comp-tests-numberp-f) - -;; (should (eq (comp-tests-integerp-f 1) t)) -;; (should (eq (comp-tests-integerp-f '(1)) nil)) -;; (should (eq (comp-tests-integerp-f 3.5) nil)) -;; (should (eq (comp-tests-integerp-f (1+ most-negative-fixnum)) t)) - -;; (should (eq (comp-tests-numberp-f 1) t)) -;; (should (eq (comp-tests-numberp-f 'a) nil)) -;; (should (eq (comp-tests-numberp-f 3.5) t))) +(ert-deftest comp-tests-list-inline () + "Test some inlined list functions." + (defun comp-tests-consp-f (x) + ;; Bconsp + (consp x)) + (defun comp-tests-car-f (x) + ;; Bsetcar + (setcar x 3)) + + (native-compile #'comp-tests-consp-f) + (native-compile #'comp-tests-car-f) + + (should (eq (comp-tests-consp-f '(1)) t)) + (should (eq (comp-tests-consp-f 1) nil)) + (let ((x (cons 1 2))) + (should (= (comp-tests-car-f x) 3)) + (should (equal x '(3 . 2))))) + +(ert-deftest comp-tests-num-inline () + "Test some inlined number functions." + (defun comp-tests-integerp-f (x) + ;; Bintegerp + (integerp x)) + (defun comp-tests-numberp-f (x) + ;; Bnumberp + (numberp x)) + + (native-compile #'comp-tests-integerp-f) + (native-compile #'comp-tests-numberp-f) + + (should (eq (comp-tests-integerp-f 1) t)) + (should (eq (comp-tests-integerp-f '(1)) nil)) + (should (eq (comp-tests-integerp-f 3.5) nil)) + (should (eq (comp-tests-integerp-f (1+ most-negative-fixnum)) t)) + + (should (eq (comp-tests-numberp-f 1) t)) + (should (eq (comp-tests-numberp-f 'a) nil)) + (should (eq (comp-tests-numberp-f 3.5) t))) ;; (ert-deftest comp-tests-stack () ;; "Test some stack operation." @@ -467,11 +467,11 @@ ;; (should (= (catch 'foo ;; (comp-tests-throw-f 3))))) -;; (ert-deftest comp-tests-gc () -;; "Try to do some longer computation to let the gc kick in." -;; (dotimes (_ 100000) -;; (comp-tests-cons-cdr-f 3)) +(ert-deftest comp-tests-gc () + "Try to do some longer computation to let the gc kick in." + (dotimes (_ 100000) + (comp-tests-cons-cdr-f 3)) -;; (should (= (comp-tests-cons-cdr-f 3) 3))) + (should (= (comp-tests-cons-cdr-f 3) 3))) ;;; comp-tests.el ends here commit 231c71706b3b5eec8038986f54198a8983ae83c0 Author: Andrea Corallo Date: Sat Jul 20 17:35:57 2019 +0200 Add other ops diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 6bc293e596..cdbae34387 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -398,6 +398,8 @@ the annotation emission." (intern (replace-regexp-in-string "byte-" "" x))) (body-eff (body op-name sp-delta) ;; Given the original body BODY compute the effective one. + ;; When BODY is auto guess function name form the LAP bytecode + ;; name. Othewise expect lname fnname. (pcase (car body) ('auto (list `(comp-emit-set-call-subr @@ -415,9 +417,11 @@ the annotation emission." for op-name = (symbol-name op) if body collect `(',op + ;; Log all LAP ops except the TAG one. ,(unless (eq op 'TAG) `(comp-emit-annotation ,(concat "LAP op " op-name))) + ;; Emit the stack adjustment if present. ,(when (and sp-delta (not (eq 0 sp-delta))) `(comp-stack-adjust ,sp-delta)) ,@(body-eff body op-name sp-delta)) @@ -470,7 +474,7 @@ the annotation emission." (byte-listp auto) (byte-eq auto) (byte-memq auto) - (byte-not) + (byte-not null Fnull) (byte-car auto) (byte-cdr auto) (byte-cons auto) @@ -497,15 +501,15 @@ the annotation emission." (comp-emit-set-call `(callref Fconcat 3 ,(comp-sp)))) (byte-concat4 (comp-emit-set-call `(callref Fconcat 4 ,(comp-sp)))) - (byte-sub1 1+ Fadd1) - (byte-add1 1- Fsub1) - (byte-eqlsign string-equal Fstring-equal) + (byte-sub1 1- Fsub1) + (byte-add1 1+ Fadd1) + (byte-eqlsign = Feqlsign) (byte-gtr > Fgtr) (byte-lss < Flss) (byte-leq <= Fleq) (byte-geq >= Fgeq) - (byte-diff - Fmius) - (byte-negate null Fnull) + (byte-diff - Fminus) + (byte-negate - Fminus) (byte-plus + Fplus) (byte-max auto) (byte-min auto) @@ -580,8 +584,8 @@ the annotation emission." (byte-match-end auto) (byte-upcase auto) (byte-downcase auto) - (byte-string=) - (byte-string<) + (byte-string= string-equal Fstring_equal) + (byte-string< string-lessp Fstring_lessp) (byte-equal auto) (byte-nthcdr auto) (byte-elt auto) @@ -590,13 +594,11 @@ the annotation emission." (byte-nreverse auto) (byte-setcar auto) (byte-setcdr auto) - (byte-car-safe - (comp-emit-set-call `(call Fcar_safe ,(comp-slot)))) - (byte-cdr-safe - (comp-emit-set-call `(call Fcdr_safe ,(comp-slot)))) + (byte-car-safe auto) + (byte-cdr-safe auto) (byte-nconc auto) - (byte-quo) - (byte-rem) + (byte-quo / Fquo) + (byte-rem % Frem) (byte-numberp auto) (byte-integerp auto) (byte-listN) commit 45a4510738a0878267fca5fdd687981c70209023 Author: Andrea Corallo Date: Sat Jul 20 17:22:13 2019 +0200 adding ops diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 89a35d1fe5..6bc293e596 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -497,23 +497,19 @@ the annotation emission." (comp-emit-set-call `(callref Fconcat 3 ,(comp-sp)))) (byte-concat4 (comp-emit-set-call `(callref Fconcat 4 ,(comp-sp)))) - (byte-sub1) - (byte-add1) - (byte-eqlsign - (comp-emit-set-call `(call Fstring_equal - ,(comp-slot) - ,(comp-slot-next)))) - (byte-gtr) - (byte-lss) - (byte-leq) - (byte-geq) - (byte-diff) - (byte-negate) - (byte-plus - (comp-emit-set-call `(callref Fplus 2 ,(comp-sp)))) + (byte-sub1 1+ Fadd1) + (byte-add1 1- Fsub1) + (byte-eqlsign string-equal Fstring-equal) + (byte-gtr > Fgtr) + (byte-lss < Flss) + (byte-leq <= Fleq) + (byte-geq >= Fgeq) + (byte-diff - Fmius) + (byte-negate null Fnull) + (byte-plus + Fplus) (byte-max auto) (byte-min auto) - (byte-mult) + (byte-mult * Ftimes) (byte-point auto) (byte-goto-char auto) (byte-insert auto) commit c7341aad72ee4cfca5c989ef982f07fbd14d8837 Author: Andrea Corallo Date: Sat Jul 20 16:44:40 2019 +0200 improve comp-op-case again diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index fceea59860..89a35d1fe5 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -393,18 +393,26 @@ This is responsible for generating the proper stack adjustment when known and the annotation emission." (declare (debug (body)) (indent defun)) - (cl-flet ((op-to-fun (x) - ;; Given the LAP op strip "byte-" to have the subr name. - (intern (replace-regexp-in-string "byte-" "" x)))) + (cl-labels ((op-to-fun (x) + ;; Given the LAP op strip "byte-" to have the subr name. + (intern (replace-regexp-in-string "byte-" "" x))) + (body-eff (body op-name sp-delta) + ;; Given the original body BODY compute the effective one. + (pcase (car body) + ('auto + (list `(comp-emit-set-call-subr + ,(op-to-fun op-name) + ,sp-delta))) + ((pred symbolp) + (list `(comp-emit-set-call-subr + ,(car body) + ,sp-delta + ,(cadr body)))) + (_ body)))) `(pcase op ,@(cl-loop for (op . body) in cases for sp-delta = (gethash op comp-op-stack-info) for op-name = (symbol-name op) - for body-eff = (if (eq (car body) 'auto) - (list `(comp-emit-set-call-subr - ,(op-to-fun op-name) - ,sp-delta)) - body) if body collect `(',op ,(unless (eq op 'TAG) @@ -412,7 +420,7 @@ the annotation emission." ,(concat "LAP op " op-name))) ,(when (and sp-delta (not (eq 0 sp-delta))) `(comp-stack-adjust ,sp-delta)) - ,@body-eff) + ,@(body-eff body op-name sp-delta)) else collect `(',op (error ,(concat "Unsupported LAP op " op-name)))) commit f78257006c46ac537aba00658b11a75a11bd1fce Author: Andrea Corallo Date: Sat Jul 20 16:34:37 2019 +0200 add a bunch of ops diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 99e71a0d58..fceea59860 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -284,7 +284,7 @@ If C-FUN-NAME is nil it will be guessed from SUBR-NAME." "Set current slot with slot number N as source." (let ((src-slot (comp-slot-n n))) (cl-assert src-slot) - ;; Should the id increased here? + ;; FIXME id should encrease here. (setf (comp-slot) (copy-sequence src-slot)) (setf (comp-mvar-slot (comp-slot)) (comp-sp)) @@ -482,7 +482,7 @@ the annotation emission." (byte-set auto) (byte-fset auto) (byte-get auto) - (byte-substring) + (byte-substring auto) (byte-concat2 (comp-emit-set-call `(callref Fconcat 2 ,(comp-sp)))) (byte-concat3 @@ -503,19 +503,19 @@ the annotation emission." (byte-negate) (byte-plus (comp-emit-set-call `(callref Fplus 2 ,(comp-sp)))) - (byte-max) - (byte-min) + (byte-max auto) + (byte-min auto) (byte-mult) (byte-point auto) (byte-goto-char auto) - (byte-insert) + (byte-insert auto) (byte-point-max auto) (byte-point-min auto) - (byte-char-after) + (byte-char-after auto) (byte-following-char auto) (byte-preceding-char auto) (byte-current-column auto) - (byte-indent-to) + (byte-indent-to auto) (byte-scan-buffer-OBSOLETE) (byte-eolp auto) (byte-eobp auto) @@ -526,17 +526,17 @@ the annotation emission." (byte-save-current-buffer) (byte-set-mark-OBSOLETE) (byte-interactive-p-OBSOLETE) - (byte-forward-char) - (byte-forward-word) - (byte-skip-chars-forward) - (byte-skip-chars-backward) - (byte-forward-line) + (byte-forward-char auto) + (byte-forward-word auto) + (byte-skip-chars-forward auto) + (byte-skip-chars-backward auto) + (byte-forward-line auto) (byte-char-syntax auto) (byte-buffer-substring auto) (byte-delete-region auto) (byte-narrow-to-region) (byte-widen) - (byte-end-of-line) + (byte-end-of-line auto) (byte-constant2) (byte-goto (let ((bb (comp-new-block-sym)) @@ -571,14 +571,14 @@ the annotation emission." (byte-temp-output-buffer-setup-OBSOLETE) (byte-temp-output-buffer-show-OBSOLETE) (byte-unbind-all) - (byte-set-marker) - (byte-match-beginning) - (byte-match-end) - (byte-upcase) - (byte-downcase) + (byte-set-marker auto) + (byte-match-beginning auto) + (byte-match-end auto) + (byte-upcase auto) + (byte-downcase auto) (byte-string=) (byte-string<) - (byte-equal) + (byte-equal auto) (byte-nthcdr auto) (byte-elt auto) (byte-member auto) @@ -590,7 +590,7 @@ the annotation emission." (comp-emit-set-call `(call Fcar_safe ,(comp-slot)))) (byte-cdr-safe (comp-emit-set-call `(call Fcdr_safe ,(comp-slot)))) - (byte-nconc) + (byte-nconc auto) (byte-quo) (byte-rem) (byte-numberp auto) commit a556a2ef5b45a25ff5df9a7cf3dc50e1ec46224b Author: Andrea Corallo Date: Sat Jul 20 15:49:30 2019 +0200 improve comp-op-case diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 186ec1ca57..99e71a0d58 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -248,11 +248,13 @@ If the calle function is known to have a return type propagate it." comp-known-ret-types)))) (comp-emit (list 'set (comp-slot) call))) -(defmacro comp-emit-set-call-subr (subr-name &optional c-fun-name) +(defmacro comp-emit-set-call-subr (subr-name sp-delta &optional c-fun-name) "Emit a call for SUBR-NAME using C-FUN-NAME. -If C-FUN-NAME is nil will be guessed from SUBR-NAME." +SP-DELTA is the stack adjustment. +If C-FUN-NAME is nil it will be guessed from SUBR-NAME." (let ((subr (symbol-function subr-name)) - (subr-str (symbol-name subr-name))) + (subr-str (symbol-name subr-name)) + (nargs (1+ (- sp-delta)))) (cl-assert (subrp subr) nil "%s not a subr" subr-str) (let* ((arity (subr-arity subr)) @@ -264,14 +266,19 @@ If C-FUN-NAME is nil will be guessed from SUBR-NAME." (replace-regexp-in-string "-" "_" subr-str))))) - (cl-assert (not (or (eq maxarg 'many) (eq maxarg 'unevalled))) nil - "%s contains %s arg" subr-name maxarg ) - (cl-assert (= minarg maxarg) (minarg maxarg) - "args %d %d differs for %s" subr-name) - `(let ((c-fun-name ',c-fun-name) - (slots (cl-loop for i from 0 below ,maxarg - collect (comp-slot-n (+ i (comp-sp)))))) - (comp-emit-set-call `(call ,c-fun-name ,@slots)))))) + (cl-assert (not (eq maxarg 'unevalled)) nil + "%s contains unevalled arg" subr-name) + (if (eq maxarg 'many) + ;; callref case. + `(comp-emit-set-call (list 'callref ',c-fun-name ,nargs (comp-sp))) + ;; Normal call. + (cl-assert (and (>= maxarg nargs) (<= minarg nargs)) + (nargs maxarg minarg) + "Incoherent stack adjustment %d, maxarg %d minarg %d") + `(let* ((c-fun-name ',c-fun-name) + (slots (cl-loop for i from 0 below ,maxarg + collect (comp-slot-n (+ i (comp-sp)))))) + (comp-emit-set-call `(call ,c-fun-name ,@slots))))))) (defun comp-copy-slot-n (n) "Set current slot with slot number N as source." @@ -395,16 +402,17 @@ the annotation emission." for op-name = (symbol-name op) for body-eff = (if (eq (car body) 'auto) (list `(comp-emit-set-call-subr - ,(op-to-fun op-name))) + ,(op-to-fun op-name) + ,sp-delta)) body) if body collect `(',op ,(unless (eq op 'TAG) `(comp-emit-annotation ,(concat "LAP op " op-name))) - ,(when sp-delta + ,(when (and sp-delta (not (eq 0 sp-delta))) `(comp-stack-adjust ,sp-delta)) - (progn ,@body-eff)) + ,@body-eff) else collect `(',op (error ,(concat "Unsupported LAP op " op-name)))) commit fb9711df98be83c357321761d06e902e5410da79 Author: Andrea Corallo Date: Thu Jul 18 17:57:01 2019 +0200 uncommenting some tests diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index e27e585ea5..d11cf8657c 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -168,38 +168,37 @@ ;; (should (equal (comp-tests-ffuncall-callee-rest-f 1 2 3) '(1 2 (3)))) ;; (should (equal (comp-tests-ffuncall-callee-rest-f 1 2 3 4) '(1 2 (3 4)))) - ;; (defun comp-tests-ffuncall-native-f () - ;; "Call a primitive with no dedicate op." - ;; (make-vector 1 nil)) + (defun comp-tests-ffuncall-native-f () + "Call a primitive with no dedicate op." + (make-vector 1 nil)) - ;; (native-compile #'comp-tests-ffuncall-native-f) + (native-compile #'comp-tests-ffuncall-native-f) - ;; (should (equal (comp-tests-ffuncall-native-f) [nil])) + (should (equal (comp-tests-ffuncall-native-f) [nil])) - ;; (defun comp-tests-ffuncall-native-rest-f () - ;; "Call a primitive with no dedicate op with &rest." - ;; (vector 1 2 3)) + (defun comp-tests-ffuncall-native-rest-f () + "Call a primitive with no dedicate op with &rest." + (vector 1 2 3)) - ;; (native-compile #'comp-tests-ffuncall-native-rest-f) + (native-compile #'comp-tests-ffuncall-native-rest-f) - ;; (should (equal (comp-tests-ffuncall-native-rest-f) [1 2 3])) + (should (equal (comp-tests-ffuncall-native-rest-f) [1 2 3])) - ;; (defun comp-tests-ffuncall-apply-many-f (x) - ;; (apply #'list x)) + (defun comp-tests-ffuncall-apply-many-f (x) + (apply #'list x)) - ;; (native-compile #'comp-tests-ffuncall-apply-many-f) + (native-compile #'comp-tests-ffuncall-apply-many-f) - ;; (should (equal (comp-tests-ffuncall-apply-many-f '(1 2 3)) '(1 2 3))) + (should (equal (comp-tests-ffuncall-apply-many-f '(1 2 3)) '(1 2 3))) - ;; (defun comp-tests-ffuncall-lambda-f (x) - ;; (let ((fun (lambda (x) - ;; (1+ x)))) - ;; (funcall fun x))) + (defun comp-tests-ffuncall-lambda-f (x) + (let ((fun (lambda (x) + (1+ x)))) + (funcall fun x))) - ;; (native-compile #'comp-tests-ffuncall-lambda-f) + (native-compile #'comp-tests-ffuncall-lambda-f) - ;; (should (= (comp-tests-ffuncall-lambda-f 1) 2)) - ) + (should (= (comp-tests-ffuncall-lambda-f 1) 2))) ;; (ert-deftest comp-tests-jump-table () ;; "Testing jump tables" commit 13811eba32c8d43126e3d137ddcedbdab4dd81c6 Author: Andrea Corallo Date: Thu Jul 18 17:35:30 2019 +0200 better generated code diff --git a/src/comp.c b/src/comp.c index 03a9e4b286..152a0e6180 100644 --- a/src/comp.c +++ b/src/comp.c @@ -35,6 +35,15 @@ along with GNU Emacs. If not, see . */ #define COMP_DEBUG 1 +/* + If 1 always favorite the emission of direct constants when these are know + instead of the corresponding frame slot access. + This has to prove to have some perf advantage but certainly makes the + generated code C-like code more bloated. +*/ + +#define CONST_PROP_MAX 0 + #define STR(s) #s #define FIRST(x) \ @@ -958,12 +967,27 @@ emit_PURE_P (gcc_jit_rvalue *ptr) static gcc_jit_rvalue * emit_mvar_val (Lisp_Object mvar) { - if (NILP (FUNCALL1 (comp-mvar-const-vld, mvar))) - return - gcc_jit_lvalue_as_rvalue( - comp.frame[XFIXNUM (FUNCALL1 (comp-mvar-slot, mvar))]); + if (CONST_PROP_MAX) + { + if (NILP (FUNCALL1 (comp-mvar-const-vld, mvar))) + return + gcc_jit_lvalue_as_rvalue( + comp.frame[XFIXNUM (FUNCALL1 (comp-mvar-slot, mvar))]); + else + return emit_lisp_obj_from_ptr (FUNCALL1 (comp-mvar-constant, mvar)); + } else - return emit_lisp_obj_from_ptr (FUNCALL1 (comp-mvar-constant, mvar)); + { + if (NILP (FUNCALL1 (comp-mvar-slot, mvar))) + { + /* If the slot is not specified this must be a constant. */ + eassert (!NILP (FUNCALL1 (comp-mvar-const-vld, mvar))); + return emit_lisp_obj_from_ptr (FUNCALL1 (comp-mvar-constant, mvar)); + } + return + gcc_jit_lvalue_as_rvalue( + comp.frame[XFIXNUM (FUNCALL1 (comp-mvar-slot, mvar))]); + } } static gcc_jit_rvalue * @@ -1007,7 +1031,7 @@ emit_limple_call (Lisp_Object arg1) SET_INTERNAL_SET); return emit_call ("set_internal", comp.void_type , 4, gcc_args); } - error ("LIMPLE call is inconsistet"); + error ("LIMPLE call is inconsistent"); } static gcc_jit_rvalue * commit c87027e054ec247f3c7b80b2159cfcc633bfab7c Author: Andrea Corallo Date: Mon Jul 15 00:58:03 2019 +0200 adding some ops diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index f13a3fd148..186ec1ca57 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -37,7 +37,9 @@ (defconst comp-debug t) +;; FIXME these has to be removed (defvar comp-speed 2) +(defvar byte-compile-lap-output) (defconst comp-passes '(comp-recuparate-lap comp-limplify) @@ -262,8 +264,8 @@ If C-FUN-NAME is nil will be guessed from SUBR-NAME." (replace-regexp-in-string "-" "_" subr-str))))) - (cl-assert (not (eq maxarg 'many)) nil - "%s contains may args" subr-name) + (cl-assert (not (or (eq maxarg 'many) (eq maxarg 'unevalled))) nil + "%s contains %s arg" subr-name maxarg ) (cl-assert (= minarg maxarg) (minarg maxarg) "args %d %d differs for %s" subr-name) `(let ((c-fun-name ',c-fun-name) @@ -385,7 +387,7 @@ the annotation emission." (declare (debug (body)) (indent defun)) (cl-flet ((op-to-fun (x) - ;;Given the LAP op strip "byte-" + ;; Given the LAP op strip "byte-" to have the subr name. (intern (replace-regexp-in-string "byte-" "" x)))) `(pcase op ,@(cl-loop for (op . body) in cases @@ -445,9 +447,9 @@ the annotation emission." (byte-pophandler) (byte-pushconditioncase) (byte-pushcatch) - (byte-nth) - (byte-symbolp) - (byte-consp) + (byte-nth auto) + (byte-symbolp auto) + (byte-consp auto) (byte-stringp auto) (byte-listp auto) (byte-eq auto) @@ -468,7 +470,7 @@ the annotation emission." (byte-aref auto) (byte-aset auto) (byte-symbol-value auto) - (byte-symbol-function) + (byte-symbol-function auto) (byte-set auto) (byte-fset auto) (byte-get auto) @@ -496,23 +498,23 @@ the annotation emission." (byte-max) (byte-min) (byte-mult) - (byte-point) + (byte-point auto) (byte-goto-char auto) (byte-insert) - (byte-point-max) - (byte-point-min) + (byte-point-max auto) + (byte-point-min auto) (byte-char-after) (byte-following-char auto) - (byte-preceding-char) - (byte-current-column) + (byte-preceding-char auto) + (byte-current-column auto) (byte-indent-to) (byte-scan-buffer-OBSOLETE) - (byte-eolp) - (byte-eobp) - (byte-bolp) - (byte-bobp) - (byte-current-buffer) - (byte-set-buffer) + (byte-eolp auto) + (byte-eobp auto) + (byte-bolp auto) + (byte-bobp auto) + (byte-current-buffer auto) + (byte-set-buffer auto) (byte-save-current-buffer) (byte-set-mark-OBSOLETE) (byte-interactive-p-OBSOLETE) @@ -521,9 +523,9 @@ the annotation emission." (byte-skip-chars-forward) (byte-skip-chars-backward) (byte-forward-line) - (byte-char-syntax) - (byte-buffer-substring) - (byte-delete-region) + (byte-char-syntax auto) + (byte-buffer-substring auto) + (byte-delete-region auto) (byte-narrow-to-region) (byte-widen) (byte-end-of-line) @@ -569,13 +571,13 @@ the annotation emission." (byte-string=) (byte-string<) (byte-equal) - (byte-nthcdr) - (byte-elt) - (byte-member) - (byte-assq) - (byte-nreverse) - (byte-setcar) - (byte-setcdr) + (byte-nthcdr auto) + (byte-elt auto) + (byte-member auto) + (byte-assq auto) + (byte-nreverse auto) + (byte-setcar auto) + (byte-setcdr auto) (byte-car-safe (comp-emit-set-call `(call Fcar_safe ,(comp-slot)))) (byte-cdr-safe @@ -583,8 +585,8 @@ the annotation emission." (byte-nconc) (byte-quo) (byte-rem) - (byte-numberp) - (byte-integerp) + (byte-numberp auto) + (byte-integerp auto) (byte-listN) (byte-concatN (comp-stack-adjust (- (1- arg))) @@ -609,7 +611,7 @@ the annotation emission." (comp-emit-block 'entry) (comp-emit-annotation (concat "Lisp function: " (symbol-name (comp-func-symbol-name func)))) - (cl-loop for i below (comp-args-mandatory (comp-func-args func)) + (cl-loop for i below (comp-args-min (comp-func-args func)) do (progn (cl-incf (comp-sp)) (push `(setpar ,(comp-slot) ,i) comp-limple))) commit 099f9159c4312ad17e51fd3c9571cf525fc01b15 Author: Andrea Corallo Date: Sun Jul 14 23:35:04 2019 +0200 rework comp.el diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index f4718fb538..f13a3fd148 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -249,22 +249,27 @@ If the calle function is known to have a return type propagate it." (defmacro comp-emit-set-call-subr (subr-name &optional c-fun-name) "Emit a call for SUBR-NAME using C-FUN-NAME. If C-FUN-NAME is nil will be guessed from SUBR-NAME." - (let* ((arity (subr-arity (symbol-function subr-name))) - (minarg (car arity)) - (maxarg (cdr arity))) - (unless c-fun-name - (setq c-fun-name - (intern (concat "F" - (replace-regexp-in-string - "-" "_" - (symbol-name subr-name)))))) - (if (eq maxarg 'many) - (error "Not implemented") - (cl-assert (= minarg maxarg)) - `(let ((c-fun-name ',c-fun-name) - (slots (cl-loop for i from 0 below ,maxarg - collect (comp-slot-n (+ i (comp-sp)))))) - (comp-emit-set-call `(call ,c-fun-name ,@slots)))))) + (let ((subr (symbol-function subr-name)) + (subr-str (symbol-name subr-name))) + (cl-assert (subrp subr) nil + "%s not a subr" subr-str) + (let* ((arity (subr-arity subr)) + (minarg (car arity)) + (maxarg (cdr arity))) + (unless c-fun-name + (setq c-fun-name + (intern (concat "F" + (replace-regexp-in-string + "-" "_" + subr-str))))) + (cl-assert (not (eq maxarg 'many)) nil + "%s contains may args" subr-name) + (cl-assert (= minarg maxarg) (minarg maxarg) + "args %d %d differs for %s" subr-name) + `(let ((c-fun-name ',c-fun-name) + (slots (cl-loop for i from 0 below ,maxarg + collect (comp-slot-n (+ i (comp-sp)))))) + (comp-emit-set-call `(call ,c-fun-name ,@slots)))))) (defun comp-copy-slot-n (n) "Set current slot with slot number N as source." @@ -379,22 +384,29 @@ This is responsible for generating the proper stack adjustment when known and the annotation emission." (declare (debug (body)) (indent defun)) - `(pcase op - ,@(cl-loop for (op . body) in cases - for sp-delta = (gethash op comp-op-stack-info) - for op-name = (symbol-name op) - if body - collect `(',op - ,(unless (eq op 'TAG) - `(comp-emit-annotation - ,(concat "LAP op " op-name))) - ,(when sp-delta - `(comp-stack-adjust ,sp-delta)) - (progn ,@body)) - else - collect `(',op (error ,(concat "Unsupported LAP op " - op-name)))) - (_ (error "Unexpected LAP op %s" (symbol-name op))))) + (cl-flet ((op-to-fun (x) + ;;Given the LAP op strip "byte-" + (intern (replace-regexp-in-string "byte-" "" x)))) + `(pcase op + ,@(cl-loop for (op . body) in cases + for sp-delta = (gethash op comp-op-stack-info) + for op-name = (symbol-name op) + for body-eff = (if (eq (car body) 'auto) + (list `(comp-emit-set-call-subr + ,(op-to-fun op-name))) + body) + if body + collect `(',op + ,(unless (eq op 'TAG) + `(comp-emit-annotation + ,(concat "LAP op " op-name))) + ,(when sp-delta + `(comp-stack-adjust ,sp-delta)) + (progn ,@body-eff)) + else + collect `(',op (error ,(concat "Unsupported LAP op " + op-name)))) + (_ (error "Unexpected LAP op %s" (symbol-name op)))))) (defun comp-limplify-lap-inst (inst) "Limplify LAP instruction INST accumulating in `comp-limple'." @@ -436,17 +448,14 @@ the annotation emission." (byte-nth) (byte-symbolp) (byte-consp) - (byte-stringp) - (byte-listp) - (byte-eq) - (byte-memq) + (byte-stringp auto) + (byte-listp auto) + (byte-eq auto) + (byte-memq auto) (byte-not) - (byte-car - (comp-emit-set-call-subr car)) - (byte-cdr - (comp-emit-set-call-subr cdr)) - (byte-cons - (comp-emit-set-call-subr cons)) + (byte-car auto) + (byte-cdr auto) + (byte-cons auto) (byte-list1 (comp-limplify-listn 1)) (byte-list2 @@ -455,18 +464,14 @@ the annotation emission." (comp-limplify-listn 3)) (byte-list4 (comp-limplify-listn 4)) - (byte-length - (comp-emit-set-call-subr length)) - (byte-aref - (comp-emit-set-call-subr aref)) - (byte-aset - (comp-emit-set-call-subr aset)) - (byte-symbol-value - (comp-emit-set-call-subr symbol-value)) + (byte-length auto) + (byte-aref auto) + (byte-aset auto) + (byte-symbol-value auto) (byte-symbol-function) - (byte-set) - (byte-fset) - (byte-get) + (byte-set auto) + (byte-fset auto) + (byte-get auto) (byte-substring) (byte-concat2 (comp-emit-set-call `(callref Fconcat 2 ,(comp-sp)))) @@ -476,7 +481,10 @@ the annotation emission." (comp-emit-set-call `(callref Fconcat 4 ,(comp-sp)))) (byte-sub1) (byte-add1) - (byte-eqlsign) + (byte-eqlsign + (comp-emit-set-call `(call Fstring_equal + ,(comp-slot) + ,(comp-slot-next)))) (byte-gtr) (byte-lss) (byte-leq) @@ -489,12 +497,12 @@ the annotation emission." (byte-min) (byte-mult) (byte-point) - (byte-goto-char) + (byte-goto-char auto) (byte-insert) (byte-point-max) (byte-point-min) (byte-char-after) - (byte-following-char) + (byte-following-char auto) (byte-preceding-char) (byte-current-column) (byte-indent-to) @@ -541,7 +549,7 @@ the annotation emission." (byte-return (comp-emit (list 'return (comp-slot-next))) (comp-mark-block-closed)) - (byte-discard t) + (byte-discard 'pass) (byte-dup (comp-copy-slot-n (1- (comp-sp)))) (byte-save-excursion) commit f9723f947a919f70aeb54a9cb6515a4ead3c90d3 Author: Andrea Corallo Date: Sun Jul 14 21:02:01 2019 +0200 fix goto diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index f115292dbf..f4718fb538 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -259,9 +259,7 @@ If C-FUN-NAME is nil will be guessed from SUBR-NAME." "-" "_" (symbol-name subr-name)))))) (if (eq maxarg 'many) - (progn - (cl-assert (= minarg 0)) - `(error "To be implemented")) + (error "Not implemented") (cl-assert (= minarg maxarg)) `(let ((c-fun-name ',c-fun-name) (slots (cl-loop for i from 0 below ,maxarg @@ -272,7 +270,7 @@ If C-FUN-NAME is nil will be guessed from SUBR-NAME." "Set current slot with slot number N as source." (let ((src-slot (comp-slot-n n))) (cl-assert src-slot) - ;; FIXME should the id increase? + ;; Should the id increased here? (setf (comp-slot) (copy-sequence src-slot)) (setf (comp-mvar-slot (comp-slot)) (comp-sp)) @@ -377,7 +375,8 @@ If NEGATED non nil negate the test condition." (defmacro comp-op-case (&rest cases) "Expand CASES into the corresponding pcase. -This is responsible for generating the proper stack adjustment when known." +This is responsible for generating the proper stack adjustment when known and +the annotation emission." (declare (debug (body)) (indent defun)) `(pcase op @@ -522,12 +521,15 @@ This is responsible for generating the proper stack adjustment when known." (byte-end-of-line) (byte-constant2) (byte-goto - (comp-with-fall-through-block bb 0 - (let ((target (comp-lap-to-limple-bb (cl-third inst)))) - (comp-emit-jump target) - (puthash target - (make-comp-block :sp (comp-sp)) - (comp-func-blocks comp-func))))) + (let ((bb (comp-new-block-sym)) + (blocks (comp-func-blocks comp-func)) + (target (comp-lap-to-limple-bb (cl-third inst)))) + (puthash bb (make-comp-block :sp (comp-sp)) blocks) + (comp-emit-jump target) + (puthash target + (make-comp-block :sp (comp-sp)) + blocks) + (comp-emit-block bb))) (byte-goto-if-nil (comp-emit-cond-jump 0 (cl-third inst) nil)) (byte-goto-if-not-nil commit 53947aa60b193ec9a34442d4492ddee9ea36ff30 Author: Andrea Corallo Date: Sun Jul 14 20:25:42 2019 +0200 add comp-emit-set-call-subr macro diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 10fe10fed2..f115292dbf 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -246,6 +246,28 @@ If the calle function is known to have a return type propagate it." comp-known-ret-types)))) (comp-emit (list 'set (comp-slot) call))) +(defmacro comp-emit-set-call-subr (subr-name &optional c-fun-name) + "Emit a call for SUBR-NAME using C-FUN-NAME. +If C-FUN-NAME is nil will be guessed from SUBR-NAME." + (let* ((arity (subr-arity (symbol-function subr-name))) + (minarg (car arity)) + (maxarg (cdr arity))) + (unless c-fun-name + (setq c-fun-name + (intern (concat "F" + (replace-regexp-in-string + "-" "_" + (symbol-name subr-name)))))) + (if (eq maxarg 'many) + (progn + (cl-assert (= minarg 0)) + `(error "To be implemented")) + (cl-assert (= minarg maxarg)) + `(let ((c-fun-name ',c-fun-name) + (slots (cl-loop for i from 0 below ,maxarg + collect (comp-slot-n (+ i (comp-sp)))))) + (comp-emit-set-call `(call ,c-fun-name ,@slots)))))) + (defun comp-copy-slot-n (n) "Set current slot with slot number N as source." (let ((src-slot (comp-slot-n n))) @@ -260,7 +282,7 @@ If the calle function is known to have a return type propagate it." "Emit annotation STR." (comp-emit `(comment ,str))) -(defun comp-set-const (val) +(defun comp-emit-set-const (val) "Set constant VAL to current slot." (setf (comp-slot) (make-comp-mvar :slot (comp-sp) :const-vld t @@ -354,7 +376,8 @@ If NEGATED non nil negate the test condition." name)))) (defmacro comp-op-case (&rest cases) - "Expand CASES into the corresponding pcase." + "Expand CASES into the corresponding pcase. +This is responsible for generating the proper stack adjustment when known." (declare (debug (body)) (indent defun)) `(pcase op @@ -420,11 +443,11 @@ If NEGATED non nil negate the test condition." (byte-memq) (byte-not) (byte-car - (comp-emit-set-call `(call Fcar ,(comp-slot)))) + (comp-emit-set-call-subr car)) (byte-cdr - (comp-emit-set-call `(call Fcdr ,(comp-slot)))) + (comp-emit-set-call-subr cdr)) (byte-cons - (comp-emit-set-call `(call Fcons ,(comp-slot) ,(comp-slot-next)))) + (comp-emit-set-call-subr cons)) (byte-list1 (comp-limplify-listn 1)) (byte-list2 @@ -434,18 +457,13 @@ If NEGATED non nil negate the test condition." (byte-list4 (comp-limplify-listn 4)) (byte-length - (comp-emit-set-call `(call Flength ,(comp-slot)))) + (comp-emit-set-call-subr length)) (byte-aref - (comp-emit-set-call `(call Faref - ,(comp-slot) - ,(comp-slot-next)))) + (comp-emit-set-call-subr aref)) (byte-aset - (comp-emit-set-call `(call Faset - ,(comp-slot) - ,(comp-slot-next) - ,(comp-slot-n (+ 2 (comp-sp)))))) + (comp-emit-set-call-subr aset)) (byte-symbol-value - (comp-emit-set-call `(call Fsymbol_value ,(comp-slot)))) + (comp-emit-set-call-subr symbol-value)) (byte-symbol-function) (byte-set) (byte-fset) @@ -567,7 +585,7 @@ If NEGATED non nil negate the test condition." (byte-discardN) (byte-switch) (byte-constant - (comp-set-const arg))))) + (comp-emit-set-const arg))))) (defun comp-limplify (func) "Given FUNC compute its LIMPLE ir." commit 5aee49d203aeae2dabd1263736c0c6bf799f4f8e Author: Andrea Corallo Date: Sun Jul 14 21:26:20 2019 +0200 byte-varbind byte-unbind diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 116a1c2445..10fe10fed2 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -394,11 +394,20 @@ If NEGATED non nil negate the test condition." ,(make-comp-mvar :const-vld t :constant arg) ,(comp-slot)))) - (byte-varbind) + (byte-varbind + (comp-emit `(call specbind + ,(make-comp-mvar :const-vld t + :constant arg) + ,(comp-slot-next)))) (byte-call (comp-stack-adjust (- arg)) (comp-emit-set-call `(callref Ffuncall ,(1+ arg) ,(comp-sp)))) - (byte-unbind) + (byte-unbind + (comp-emit `(call unbind_to + ,(make-comp-mvar :const-vld t + :constant arg) + ,(make-comp-mvar :const-vld t + :constant nil)))) (byte-pophandler) (byte-pushconditioncase) (byte-pushcatch) commit 721d1102986ad16bc71dc7a460ad08cbbe3ae979 Author: Andrea Corallo Date: Sun Jul 14 21:10:56 2019 +0200 improve comp-c-func-name diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 849b15f422..116a1c2445 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -150,7 +150,7 @@ LIMPLE basic block.") (human-readable (replace-regexp-in-string "-" "_" orig-name)) (human-readable (replace-regexp-in-string - (rx (not (any "a-z_"))) "" human-readable))) + (rx (not (any "0-9a-z_"))) "" human-readable))) (concat "F" crypted "_" human-readable))) (defun comp-decrypt-lambda-list (x) commit 15e4c44564829f2eb3a7845ae94e064540ac1a4c Author: Andrea Corallo Date: Sun Jul 14 20:54:53 2019 +0200 some code massage diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 61e35842ae..849b15f422 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -66,69 +66,69 @@ (cl-defstruct comp-args (min nil :type number - :documentation "Minimum number of arguments allowed") + :documentation "Minimum number of arguments allowed.") (max nil :documentation "Maximum number of arguments allowed -To be used when ncall-conv is nil.") +To be used when ncall-conv is nil..") (ncall-conv nil :type boolean :documentation "If t the signature is: -(ptrdiff_t nargs, Lisp_Object *args)")) +(ptrdiff_t nargs, Lisp_Object *args).")) (cl-defstruct (comp-block (:copier nil)) "A basic block." (sp nil :documentation "When non nil indicates its the sp value while entering -into it") +into it.") (closed nil :type 'boolean - :documentation "If the block was already closed")) + :documentation "If the block was already closed.")) (cl-defstruct (comp-func (:copier nil)) "Internal rapresentation for a function." (symbol-name nil - :documentation "Function symbol's name") + :documentation "Function symbol's name.") (c-func-name nil :type 'string - :documentation "The function name in the native world") + :documentation "The function name in the native world.") (func nil - :documentation "Original form") + :documentation "Original form.") (byte-func nil - :documentation "Byte compiled version") + :documentation "Byte compiled version.") (ir nil - :documentation "Current intermediate rappresentation") + :documentation "Current intermediate rappresentation.") (args nil :type 'comp-args) (frame-size nil :type 'number) (blocks (make-hash-table) :type 'hash-table :documentation "Key is the basic block symbol value is a comp-block -structure") +structure.") (lap-block (make-hash-table :test #'equal) :type 'hash-table :documentation "Key value to convert from LAP label number to -LIMPLE basic block") +LIMPLE basic block.") (limple-cnt -1 :type 'number - :documentation "Counter to create ssa limple vars")) + :documentation "Counter to create ssa limple vars.")) (cl-defstruct (comp-mvar (:copier nil) (:constructor make--comp-mvar)) "A meta-variable being a slot in the meta-stack." (id nil :type number - :documentation "SSA number") + :documentation "SSA number.") (slot nil :type fixnum - :documentation "Slot position") + :documentation "Slot position.") (const-vld nil - :documentation "Valid signal for the following slot") + :documentation "Valid signal for the following slot.") (constant nil :documentation "When const-vld non nil this is used for constant - propagation") + propagation.") (type nil - :documentation "When non nil is used for type propagation")) + :documentation "When non nil is used for type propagation.")) (cl-defstruct (comp-limplify (:copier nil)) - "Support structure used during the limplification." + "Support structure used during limplification." (sp 0 :type 'fixnum - :documentation "Current stack pointer while walking LAP") + :documentation "Current stack pointer while walking LAP.") (frame nil :type 'vector - :documentation "Meta-stack used to flat LAP") + :documentation "Meta-stack used to flat LAP.") (block-name nil :type 'symbol - :documentation "Current basic block name")) + :documentation "Current basic block name.")) -(defun comp-limplify-new-frame (size) +(defun comp-new-frame (size) "Return a clean frame of meta variables of size SIZE." (let ((v (make-vector size nil))) (cl-loop for i below size @@ -194,7 +194,7 @@ LIMPLE basic block") ;; (apply f (mapcar #'comp-mvar-constant args))))) ;; Special vars used during limplifications -(defvar comp-frame) +(defvar comp-pass) (defvar comp-limple) (defvar comp-func) @@ -205,7 +205,7 @@ LIMPLE basic block") (defmacro comp-sp () "Current stack pointer." - '(comp-limplify-sp comp-frame)) + '(comp-limplify-sp comp-pass)) (defmacro comp-with-sp (sp &rest body) "Execute BODY setting the stack pointer to SP. @@ -221,7 +221,7 @@ Restore the original value afterwards." (defmacro comp-slot-n (n) "Slot N into the meta-stack." (declare (debug (form))) - `(aref (comp-limplify-frame comp-frame) ,n)) + `(aref (comp-limplify-frame comp-pass) ,n)) (defmacro comp-slot () "Current slot into the meta-stack pointed by sp." @@ -269,7 +269,7 @@ If the calle function is known to have a return type propagate it." (defun comp-mark-block-closed () "Mark current basic block as closed." - (setf (comp-block-closed (gethash (comp-limplify-block-name comp-frame) + (setf (comp-block-closed (gethash (comp-limplify-block-name comp-pass) (comp-func-blocks comp-func))) t)) @@ -289,18 +289,18 @@ If the calle function is known to have a return type propagate it." ;; If we are abandoning an non closed basic block close it with a fall ;; through. (when (and (not (eq block-name 'entry)) - (not (comp-block-closed (gethash (comp-limplify-block-name comp-frame) + (not (comp-block-closed (gethash (comp-limplify-block-name comp-pass) blocks)))) (comp-emit-jump block-name)) ;; Every new block we are forced to wipe out all the frame. ;; This will be optimized by proper flow analysis. - (setf (comp-limplify-frame comp-frame) - (comp-limplify-new-frame (comp-func-frame-size comp-func))) + (setf (comp-limplify-frame comp-pass) + (comp-new-frame (comp-func-frame-size comp-func))) ;; If we are landing here form a recorded branch adjust sp accordingly. (setf (comp-sp) (comp-block-sp (gethash block-name blocks))) (comp-emit `(block ,block-name)) - (setf (comp-limplify-block-name comp-frame) block-name))) + (setf (comp-limplify-block-name comp-pass) block-name))) (defun comp-emit-cond-jump (discard-n lap-label negated) "Emit a conditional jump to LAP-LABEL. @@ -561,12 +561,12 @@ If NEGATED non nil negate the test condition." (comp-set-const arg))))) (defun comp-limplify (func) - "Given FUNC and return compute its LIMPLE ir." + "Given FUNC compute its LIMPLE ir." (let* ((frame-size (comp-func-frame-size func)) (comp-func func) - (comp-frame (make-comp-limplify - :sp -1 - :frame (comp-limplify-new-frame frame-size))) + (comp-pass (make-comp-limplify + :sp -1 + :frame (comp-new-frame frame-size))) (comp-limple ())) ;; Prologue (comp-emit-block 'entry) commit 8c149505a08ddec931b54e358f4d43e847920861 Author: Andrea Corallo Date: Sun Jul 14 18:36:57 2019 +0200 conditionals working diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 2135abf165..61e35842ae 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -77,7 +77,8 @@ To be used when ncall-conv is nil.") (cl-defstruct (comp-block (:copier nil)) "A basic block." (sp nil - :documentation "When non nil indicates its the sp value") + :documentation "When non nil indicates its the sp value while entering +into it") (closed nil :type 'boolean :documentation "If the block was already closed")) @@ -119,13 +120,13 @@ LIMPLE basic block") :documentation "When non nil is used for type propagation")) (cl-defstruct (comp-limplify (:copier nil)) - "This is a support structure used during the limplify pass." + "Support structure used during the limplification." (sp 0 :type 'fixnum - :documentation "Current stack pointer") + :documentation "Current stack pointer while walking LAP") (frame nil :type 'vector :documentation "Meta-stack used to flat LAP") - (block-sp (make-hash-table) :type 'hash-table - :documentation "Key is the basic block value is the stack pointer")) + (block-name nil :type 'symbol + :documentation "Current basic block name")) (defun comp-limplify-new-frame (size) "Return a clean frame of meta variables of size SIZE." @@ -266,31 +267,60 @@ If the calle function is known to have a return type propagate it." :constant val)) (comp-emit (list 'setimm (comp-slot) val))) +(defun comp-mark-block-closed () + "Mark current basic block as closed." + (setf (comp-block-closed (gethash (comp-limplify-block-name comp-frame) + (comp-func-blocks comp-func))) + t)) + +(defun comp-emit-jump (target) + "Emit an unconditional branch to block TARGET." + (comp-emit (list 'jump target)) + (comp-mark-block-closed)) + (defun comp-emit-block (block-name) "Emit basic block BLOCK-NAME." - (unless (gethash block-name (comp-func-blocks comp-func)) - (puthash block-name - (make-comp-block :sp (comp-sp)) - (comp-func-blocks comp-func))) - ;; Every new block we are forced to wipe out all the frame. - ;; This will be optimized by proper flow analysis. - (setf (comp-limplify-frame comp-frame) - (comp-limplify-new-frame (comp-func-frame-size comp-func))) - ;; If we are landing here form a recorded branch adjust sp accordingly. - (setf (comp-sp) - (comp-block-sp (gethash block-name (comp-func-blocks comp-func)))) - (comp-emit `(block ,block-name))) - -(defmacro comp-with-fall-through-block (bb &rest body) - "Create a basic block BB that is used to fall through after executing BODY." - (declare (debug (form body)) - (indent defun)) - `(let ((,bb (comp-new-block-sym))) - (puthash ,bb - (make-comp-block :sp (comp-sp)) - (comp-func-blocks comp-func)) - (progn ,@body) - (comp-emit-block ,bb))) + (let ((blocks (comp-func-blocks comp-func))) + ;; In case does not exist register it into comp-func-blocks. + (unless (gethash block-name blocks) + (puthash block-name + (make-comp-block :sp (comp-sp)) + blocks)) + ;; If we are abandoning an non closed basic block close it with a fall + ;; through. + (when (and (not (eq block-name 'entry)) + (not (comp-block-closed (gethash (comp-limplify-block-name comp-frame) + blocks)))) + (comp-emit-jump block-name)) + ;; Every new block we are forced to wipe out all the frame. + ;; This will be optimized by proper flow analysis. + (setf (comp-limplify-frame comp-frame) + (comp-limplify-new-frame (comp-func-frame-size comp-func))) + ;; If we are landing here form a recorded branch adjust sp accordingly. + (setf (comp-sp) + (comp-block-sp (gethash block-name blocks))) + (comp-emit `(block ,block-name)) + (setf (comp-limplify-block-name comp-frame) block-name))) + +(defun comp-emit-cond-jump (discard-n lap-label negated) + "Emit a conditional jump to LAP-LABEL. +Discard DISCARD-N slots afterward. +If NEGATED non nil negate the test condition." + (let ((bb (comp-new-block-sym)) + (blocks (comp-func-blocks comp-func))) + (puthash bb + (make-comp-block :sp (- (comp-sp) discard-n)) + blocks) + (progn + (let ((target (comp-lap-to-limple-bb lap-label))) + (comp-emit (if negated + (list 'cond-jump (comp-slot-next) target bb) + (list 'cond-jump (comp-slot-next) bb target))) + (puthash target + (make-comp-block :sp (comp-sp)) + blocks) + (comp-mark-block-closed))) + (comp-emit-block bb))) (defun comp-stack-adjust (n) "Move sp by N." @@ -465,47 +495,23 @@ If the calle function is known to have a return type propagate it." (byte-end-of-line) (byte-constant2) (byte-goto - (comp-with-fall-through-block bb + (comp-with-fall-through-block bb 0 (let ((target (comp-lap-to-limple-bb (cl-third inst)))) - (comp-emit (list 'jump target)) - (puthash target (comp-sp) (comp-limplify-block-sp comp-frame))) - )) + (comp-emit-jump target) + (puthash target + (make-comp-block :sp (comp-sp)) + (comp-func-blocks comp-func))))) (byte-goto-if-nil - (comp-with-fall-through-block bb - (let ((target (comp-lap-to-limple-bb (cl-third inst)))) - (comp-emit (list 'cond-jump - (comp-slot) - bb - target)) - (puthash target (comp-sp) (comp-limplify-block-sp comp-frame))))) + (comp-emit-cond-jump 0 (cl-third inst) nil)) (byte-goto-if-not-nil - (comp-with-fall-through-block bb - (let ((target (comp-lap-to-limple-bb (cl-third inst)))) - (comp-emit (list 'cond-jump - (comp-slot) - target - bb)) - (puthash target (comp-sp) (comp-limplify-block-sp comp-frame))))) + (comp-emit-cond-jump 0 (cl-third inst) t)) (byte-goto-if-nil-else-pop - (comp-with-fall-through-block bb - (let ((target (comp-lap-to-limple-bb (cl-third inst)))) - (comp-emit (list 'cond-jump - (comp-slot) - bb - target)) - (puthash target (comp-sp) (comp-limplify-block-sp comp-frame)) - (comp-stack-adjust -1)))) + (comp-emit-cond-jump 1 (cl-third inst) nil)) (byte-goto-if-not-nil-else-pop - (comp-with-fall-through-block bb - (let ((target (comp-lap-to-limple-bb (cl-third inst)))) - (comp-emit (list 'cond-jump - (comp-slot) - target - bb)) - (puthash target (comp-sp) (comp-limplify-block-sp comp-frame)) - (comp-stack-adjust -1)))) + (comp-emit-cond-jump 1 (cl-third inst) t)) (byte-return - (comp-emit (list 'return (comp-slot-next)))) + (comp-emit (list 'return (comp-slot-next))) + (comp-mark-block-closed)) (byte-discard t) (byte-dup (comp-copy-slot-n (1- (comp-sp)))) @@ -570,7 +576,7 @@ If the calle function is known to have a return type propagate it." do (progn (cl-incf (comp-sp)) (push `(setpar ,(comp-slot) ,i) comp-limple))) - (push '(jump body) comp-limple) + (comp-emit-jump 'body) ;; Body (comp-emit-block 'body) (mapc #'comp-limplify-lap-inst (comp-func-ir func)) diff --git a/src/comp.c b/src/comp.c index c97fe404ca..03a9e4b286 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1044,7 +1044,6 @@ emit_limple_inst (Lisp_Object inst) /* Unconditional branch. */ gcc_jit_block *target = retrive_block (arg0); gcc_jit_block_end_with_jump (comp.block, NULL, target); - comp.block = target; } else if (EQ (op, Qcond_jump)) { diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 8f65ee6b53..e27e585ea5 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -214,22 +214,22 @@ ;; (should (eq (comp-tests-jump-table-1-f 'y) 'b)) ;; (should (eq (comp-tests-jump-table-1-f 'xxx) 'c))) -;; (ert-deftest comp-tests-conditionals () -;; "Testing conditionals." -;; (defun comp-tests-conditionals-1-f (x) -;; ;; Generate goto-if-nil -;; (if x 1 2)) -;; (defun comp-tests-conditionals-2-f (x) -;; ;; Generate goto-if-nil-else-pop -;; (when x -;; 1340)) -;; (native-compile #'comp-tests-conditionals-1-f) -;; (native-compile #'comp-tests-conditionals-2-f) - -;; (should (= (comp-tests-conditionals-1-f t) 1)) -;; (should (= (comp-tests-conditionals-1-f nil) 2)) -;; (should (= (comp-tests-conditionals-2-f t) 1340)) -;; (should (eq (comp-tests-conditionals-2-f nil) nil))) +(ert-deftest comp-tests-conditionals () + "Testing conditionals." + (defun comp-tests-conditionals-1-f (x) + ;; Generate goto-if-nil + (if x 1 2)) + (defun comp-tests-conditionals-2-f (x) + ;; Generate goto-if-nil-else-pop + (when x + 1340)) + (native-compile #'comp-tests-conditionals-1-f) + (native-compile #'comp-tests-conditionals-2-f) + + (should (= (comp-tests-conditionals-1-f t) 1)) + (should (= (comp-tests-conditionals-1-f nil) 2)) + (should (= (comp-tests-conditionals-2-f t) 1340)) + (should (eq (comp-tests-conditionals-2-f nil) nil))) ;; (ert-deftest comp-tests-fixnum () ;; "Testing some fixnum inline operation." commit af7bfaad6a6efa67cab0855b93ebdd920548a007 Author: Andrea Corallo Date: Sun Jul 14 17:33:18 2019 +0200 rename comp-limple-frame comp-limplify diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 6f4b94d308..2135abf165 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -118,8 +118,8 @@ LIMPLE basic block") (type nil :documentation "When non nil is used for type propagation")) -(cl-defstruct (comp-limple-frame (:copier nil)) - "This structure is used during the limplify pass." +(cl-defstruct (comp-limplify (:copier nil)) + "This is a support structure used during the limplify pass." (sp 0 :type 'fixnum :documentation "Current stack pointer") (frame nil :type 'vector @@ -127,7 +127,7 @@ LIMPLE basic block") (block-sp (make-hash-table) :type 'hash-table :documentation "Key is the basic block value is the stack pointer")) -(defun comp-limple-frame-new-frame (size) +(defun comp-limplify-new-frame (size) "Return a clean frame of meta variables of size SIZE." (let ((v (make-vector size nil))) (cl-loop for i below size @@ -204,7 +204,7 @@ LIMPLE basic block") (defmacro comp-sp () "Current stack pointer." - '(comp-limple-frame-sp comp-frame)) + '(comp-limplify-sp comp-frame)) (defmacro comp-with-sp (sp &rest body) "Execute BODY setting the stack pointer to SP. @@ -220,7 +220,7 @@ Restore the original value afterwards." (defmacro comp-slot-n (n) "Slot N into the meta-stack." (declare (debug (form))) - `(aref (comp-limple-frame-frame comp-frame) ,n)) + `(aref (comp-limplify-frame comp-frame) ,n)) (defmacro comp-slot () "Current slot into the meta-stack pointed by sp." @@ -274,8 +274,8 @@ If the calle function is known to have a return type propagate it." (comp-func-blocks comp-func))) ;; Every new block we are forced to wipe out all the frame. ;; This will be optimized by proper flow analysis. - (setf (comp-limple-frame-frame comp-frame) - (comp-limple-frame-new-frame (comp-func-frame-size comp-func))) + (setf (comp-limplify-frame comp-frame) + (comp-limplify-new-frame (comp-func-frame-size comp-func))) ;; If we are landing here form a recorded branch adjust sp accordingly. (setf (comp-sp) (comp-block-sp (gethash block-name (comp-func-blocks comp-func)))) @@ -468,7 +468,7 @@ If the calle function is known to have a return type propagate it." (comp-with-fall-through-block bb (let ((target (comp-lap-to-limple-bb (cl-third inst)))) (comp-emit (list 'jump target)) - (puthash target (comp-sp) (comp-limple-frame-block-sp comp-frame))) + (puthash target (comp-sp) (comp-limplify-block-sp comp-frame))) )) (byte-goto-if-nil (comp-with-fall-through-block bb @@ -477,7 +477,7 @@ If the calle function is known to have a return type propagate it." (comp-slot) bb target)) - (puthash target (comp-sp) (comp-limple-frame-block-sp comp-frame))))) + (puthash target (comp-sp) (comp-limplify-block-sp comp-frame))))) (byte-goto-if-not-nil (comp-with-fall-through-block bb (let ((target (comp-lap-to-limple-bb (cl-third inst)))) @@ -485,7 +485,7 @@ If the calle function is known to have a return type propagate it." (comp-slot) target bb)) - (puthash target (comp-sp) (comp-limple-frame-block-sp comp-frame))))) + (puthash target (comp-sp) (comp-limplify-block-sp comp-frame))))) (byte-goto-if-nil-else-pop (comp-with-fall-through-block bb (let ((target (comp-lap-to-limple-bb (cl-third inst)))) @@ -493,7 +493,7 @@ If the calle function is known to have a return type propagate it." (comp-slot) bb target)) - (puthash target (comp-sp) (comp-limple-frame-block-sp comp-frame)) + (puthash target (comp-sp) (comp-limplify-block-sp comp-frame)) (comp-stack-adjust -1)))) (byte-goto-if-not-nil-else-pop (comp-with-fall-through-block bb @@ -502,7 +502,7 @@ If the calle function is known to have a return type propagate it." (comp-slot) target bb)) - (puthash target (comp-sp) (comp-limple-frame-block-sp comp-frame)) + (puthash target (comp-sp) (comp-limplify-block-sp comp-frame)) (comp-stack-adjust -1)))) (byte-return (comp-emit (list 'return (comp-slot-next)))) @@ -558,9 +558,9 @@ If the calle function is known to have a return type propagate it." "Given FUNC and return compute its LIMPLE ir." (let* ((frame-size (comp-func-frame-size func)) (comp-func func) - (comp-frame (make-comp-limple-frame + (comp-frame (make-comp-limplify :sp -1 - :frame (comp-limple-frame-new-frame frame-size))) + :frame (comp-limplify-new-frame frame-size))) (comp-limple ())) ;; Prologue (comp-emit-block 'entry) commit 988a5133dc86e28e4b097d2c8d64d25e37bb6c5d Author: Andrea Corallo Date: Sun Jul 14 17:21:34 2019 +0200 block to hash diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index e2c8fe427e..6f4b94d308 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -74,6 +74,13 @@ To be used when ncall-conv is nil.") :documentation "If t the signature is: (ptrdiff_t nargs, Lisp_Object *args)")) +(cl-defstruct (comp-block (:copier nil)) + "A basic block." + (sp nil + :documentation "When non nil indicates its the sp value") + (closed nil :type 'boolean + :documentation "If the block was already closed")) + (cl-defstruct (comp-func (:copier nil)) "Internal rapresentation for a function." (symbol-name nil @@ -88,8 +95,9 @@ To be used when ncall-conv is nil.") :documentation "Current intermediate rappresentation") (args nil :type 'comp-args) (frame-size nil :type 'number) - (blocks () :type list - :documentation "List of basic block") + (blocks (make-hash-table) :type 'hash-table + :documentation "Key is the basic block symbol value is a comp-block +structure") (lap-block (make-hash-table :test #'equal) :type 'hash-table :documentation "Key value to convert from LAP label number to LIMPLE basic block") @@ -258,26 +266,31 @@ If the calle function is known to have a return type propagate it." :constant val)) (comp-emit (list 'setimm (comp-slot) val))) -(defun comp-emit-block (bblock) - "Emit basic block BBLOCK." - (cl-pushnew bblock (comp-func-blocks comp-func) :test #'eq) +(defun comp-emit-block (block-name) + "Emit basic block BLOCK-NAME." + (unless (gethash block-name (comp-func-blocks comp-func)) + (puthash block-name + (make-comp-block :sp (comp-sp)) + (comp-func-blocks comp-func))) ;; Every new block we are forced to wipe out all the frame. ;; This will be optimized by proper flow analysis. (setf (comp-limple-frame-frame comp-frame) (comp-limple-frame-new-frame (comp-func-frame-size comp-func))) ;; If we are landing here form a recorded branch adjust sp accordingly. - (if-let ((new-sp (gethash bblock (comp-limple-frame-block-sp comp-frame)))) - (setf (comp-sp) new-sp)) - (comp-emit `(block ,bblock))) + (setf (comp-sp) + (comp-block-sp (gethash block-name (comp-func-blocks comp-func)))) + (comp-emit `(block ,block-name))) (defmacro comp-with-fall-through-block (bb &rest body) "Create a basic block BB that is used to fall through after executing BODY." (declare (debug (form body)) (indent defun)) `(let ((,bb (comp-new-block-sym))) - (push ,bb (comp-func-blocks comp-func)) - (progn ,@body) - (comp-emit-block ,bb))) + (puthash ,bb + (make-comp-block :sp (comp-sp)) + (comp-func-blocks comp-func)) + (progn ,@body) + (comp-emit-block ,bb))) (defun comp-stack-adjust (n) "Move sp by N." @@ -298,7 +311,7 @@ If the calle function is known to have a return type propagate it." (defun comp-new-block-sym () "Return a symbol naming the next new basic block." - (intern (format "bb_%s" (length (comp-func-blocks comp-func))))) + (intern (format "bb_%s" (hash-table-count (comp-func-blocks comp-func))))) (defun comp-lap-to-limple-bb (n) "Given the LAP label N return the limple basic block." @@ -562,8 +575,6 @@ If the calle function is known to have a return type propagate it." (comp-emit-block 'body) (mapc #'comp-limplify-lap-inst (comp-func-ir func)) (setf (comp-func-ir func) (reverse comp-limple)) - ;; Prologue block must be first - (setf (comp-func-blocks func) (reverse (comp-func-blocks func))) (when comp-debug (cl-prettyprint (comp-func-ir func))) func)) diff --git a/src/comp.c b/src/comp.c index e407c079b6..c97fe404ca 100644 --- a/src/comp.c +++ b/src/comp.c @@ -212,7 +212,7 @@ retrive_block (Lisp_Object symbol) } static void -declare_block (char *block_name) +declare_block (const char * block_name) { gcc_jit_block *block = gcc_jit_function_new_block (comp.func, block_name); Lisp_Object key = make_string (block_name, strlen (block_name)); @@ -1977,7 +1977,7 @@ DEFUN ("comp-add-func-to-ctxt", Fcomp_add_func_to_ctxt, Scomp_add_func_to_ctxt, Lisp_Object args = FUNCALL1 (comp-func-args, func); EMACS_INT frame_size = XFIXNUM (FUNCALL1 (comp-func-frame-size, func)); EMACS_INT min_args = XFIXNUM (FUNCALL1 (comp-args-min, args)); - EMACS_INT max_args = XFIXNUM (FUNCALL1 (comp-args-max, args)); + /* EMACS_INT max_args = XFIXNUM (FUNCALL1 (comp-args-max, args)); */ bool ncall = !NILP (FUNCALL1 (comp-args-ncall-conv, args)); if (!ncall) @@ -2015,8 +2015,19 @@ DEFUN ("comp-add-func-to-ctxt", Fcomp_add_func_to_ctxt, Scomp_add_func_to_ctxt, comp.func_blocks = CALLN (Fmake_hash_table, QCtest, Qequal, QCweakness, Qt); - /* Pre declare all basic blocks. */ + /* Pre declare all basic blocks to gcc. + The "entry" block must be declared as first. */ + declare_block ("entry"); Lisp_Object blocks = FUNCALL1 (comp-func-blocks, func); + Lisp_Object entry_block = Fgethash (intern ("entry"), blocks, Qnil); + struct Lisp_Hash_Table *ht = XHASH_TABLE (blocks); + for (ptrdiff_t i = 0; i < ht->count; i++) + { + Lisp_Object block = HASH_VALUE (ht, i); + if (!EQ (block, entry_block)) + declare_block ((char *) SDATA (SYMBOL_NAME (HASH_KEY (ht, i)))); + } + while (CONSP (blocks)) { char *block_name = (char *) SDATA (SYMBOL_NAME (XCAR (blocks))); commit 1deb54f5c9c0b4f3c594e4f4aa76b42a67643976 Author: Andrea Corallo Date: Sun Jul 14 14:39:29 2019 +0200 adding conditionals diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 20ea3d2fb3..e2c8fe427e 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -21,8 +21,8 @@ ;; along with GNU Emacs. If not, see . ;;; Commentary: -;; This code is an attempt to make a Carrera out of a turbocharged VW Bug. -;; Or, to put it another way to make the pig fly. +;; This code is an attempt to make the pig fly. +;; Or, to put it another way to make a Carrera out of a turbocharged VW Bug. ;;; Code: @@ -90,6 +90,9 @@ To be used when ncall-conv is nil.") (frame-size nil :type 'number) (blocks () :type list :documentation "List of basic block") + (lap-block (make-hash-table :test #'equal) :type 'hash-table + :documentation "Key value to convert from LAP label number to +LIMPLE basic block") (limple-cnt -1 :type 'number :documentation "Counter to create ssa limple vars")) @@ -108,11 +111,13 @@ To be used when ncall-conv is nil.") :documentation "When non nil is used for type propagation")) (cl-defstruct (comp-limple-frame (:copier nil)) - "A LIMPLE func." + "This structure is used during the limplify pass." (sp 0 :type 'fixnum :documentation "Current stack pointer") (frame nil :type 'vector - :documentation "Meta-stack used to flat LAP")) + :documentation "Meta-stack used to flat LAP") + (block-sp (make-hash-table) :type 'hash-table + :documentation "Key is the basic block value is the stack pointer")) (defun comp-limple-frame-new-frame (size) "Return a clean frame of meta variables of size SIZE." @@ -195,13 +200,14 @@ To be used when ncall-conv is nil.") (defmacro comp-with-sp (sp &rest body) "Execute BODY setting the stack pointer to SP. -Restore the original value afterwads." +Restore the original value afterwards." (declare (debug (form body)) - (indent 1)) - `(let ((orig-sp (comp-sp))) - (setf (comp-sp) ,sp) - (progn ,@body) - (setf (comp-sp) orig-sp))) + (indent defun)) + (let ((sym (gensym))) + `(let ((,sym (comp-sp))) + (setf (comp-sp) ,sp) + (progn ,@body) + (setf (comp-sp) ,sym)))) (defmacro comp-slot-n (n) "Slot N into the meta-stack." @@ -235,6 +241,7 @@ If the calle function is known to have a return type propagate it." "Set current slot with slot number N as source." (let ((src-slot (comp-slot-n n))) (cl-assert src-slot) + ;; FIXME should the id increase? (setf (comp-slot) (copy-sequence src-slot)) (setf (comp-mvar-slot (comp-slot)) (comp-sp)) @@ -252,14 +259,26 @@ If the calle function is known to have a return type propagate it." (comp-emit (list 'setimm (comp-slot) val))) (defun comp-emit-block (bblock) - "Push basic block BBLOCK." - (push bblock (comp-func-blocks comp-func)) + "Emit basic block BBLOCK." + (cl-pushnew bblock (comp-func-blocks comp-func) :test #'eq) ;; Every new block we are forced to wipe out all the frame. - ;; This will be superseded by proper flow analysis. + ;; This will be optimized by proper flow analysis. (setf (comp-limple-frame-frame comp-frame) (comp-limple-frame-new-frame (comp-func-frame-size comp-func))) + ;; If we are landing here form a recorded branch adjust sp accordingly. + (if-let ((new-sp (gethash bblock (comp-limple-frame-block-sp comp-frame)))) + (setf (comp-sp) new-sp)) (comp-emit `(block ,bblock))) +(defmacro comp-with-fall-through-block (bb &rest body) + "Create a basic block BB that is used to fall through after executing BODY." + (declare (debug (form body)) + (indent defun)) + `(let ((,bb (comp-new-block-sym))) + (push ,bb (comp-func-blocks comp-func)) + (progn ,@body) + (comp-emit-block ,bb))) + (defun comp-stack-adjust (n) "Move sp by N." (cl-incf (comp-sp) n)) @@ -277,8 +296,22 @@ If the calle function is known to have a return type propagate it." ,(comp-slot) ,(comp-slot-next)))))) +(defun comp-new-block-sym () + "Return a symbol naming the next new basic block." + (intern (format "bb_%s" (length (comp-func-blocks comp-func))))) + +(defun comp-lap-to-limple-bb (n) + "Given the LAP label N return the limple basic block." + (let ((hash (comp-func-lap-block comp-func))) + (if-let ((bb (gethash n hash))) + ;; If was already created return it. + bb + (let ((name (comp-new-block-sym))) + (puthash n name hash) + name)))) + (defmacro comp-op-case (&rest cases) - "Expand CASES to the corresponding pcase." + "Expand CASES into the corresponding pcase." (declare (debug (body)) (indent defun)) `(pcase op @@ -287,8 +320,11 @@ If the calle function is known to have a return type propagate it." for op-name = (symbol-name op) if body collect `(',op - (comp-emit-annotation ,(concat "LAP op " op-name)) - (comp-stack-adjust ,(if sp-delta sp-delta 0)) + ,(unless (eq op 'TAG) + `(comp-emit-annotation + ,(concat "LAP op " op-name))) + ,(when sp-delta + `(comp-stack-adjust ,sp-delta)) (progn ,@body)) else collect `(',op (error ,(concat "Unsupported LAP op " @@ -302,6 +338,8 @@ If the calle function is known to have a return type propagate it." (cadr inst) (cdr inst)))) (comp-op-case + (TAG + (comp-emit-block (comp-lap-to-limple-bb arg))) (byte-stack-ref (comp-copy-slot-n (- (comp-sp) (cdr inst) 1))) (byte-varref @@ -413,11 +451,46 @@ If the calle function is known to have a return type propagate it." (byte-widen) (byte-end-of-line) (byte-constant2) - (byte-goto) - (byte-goto-if-nil) - (byte-goto-if-not-nil) - (byte-goto-if-nil-else-pop) - (byte-goto-if-not-nil-else-pop) + (byte-goto + (comp-with-fall-through-block bb + (let ((target (comp-lap-to-limple-bb (cl-third inst)))) + (comp-emit (list 'jump target)) + (puthash target (comp-sp) (comp-limple-frame-block-sp comp-frame))) + )) + (byte-goto-if-nil + (comp-with-fall-through-block bb + (let ((target (comp-lap-to-limple-bb (cl-third inst)))) + (comp-emit (list 'cond-jump + (comp-slot) + bb + target)) + (puthash target (comp-sp) (comp-limple-frame-block-sp comp-frame))))) + (byte-goto-if-not-nil + (comp-with-fall-through-block bb + (let ((target (comp-lap-to-limple-bb (cl-third inst)))) + (comp-emit (list 'cond-jump + (comp-slot) + target + bb)) + (puthash target (comp-sp) (comp-limple-frame-block-sp comp-frame))))) + (byte-goto-if-nil-else-pop + (comp-with-fall-through-block bb + (let ((target (comp-lap-to-limple-bb (cl-third inst)))) + (comp-emit (list 'cond-jump + (comp-slot) + bb + target)) + (puthash target (comp-sp) (comp-limple-frame-block-sp comp-frame)) + (comp-stack-adjust -1)))) + (byte-goto-if-not-nil-else-pop + (comp-with-fall-through-block bb + (let ((target (comp-lap-to-limple-bb (cl-third inst)))) + (comp-emit (list 'cond-jump + (comp-slot) + target + bb)) + (puthash target (comp-sp) (comp-limple-frame-block-sp comp-frame)) + (comp-stack-adjust -1)))) (byte-return (comp-emit (list 'return (comp-slot-next)))) (byte-discard t) diff --git a/src/comp.c b/src/comp.c index f164bf892a..e407c079b6 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1046,6 +1046,15 @@ emit_limple_inst (Lisp_Object inst) gcc_jit_block_end_with_jump (comp.block, NULL, target); comp.block = target; } + else if (EQ (op, Qcond_jump)) + { + /* Conditional branch. */ + gcc_jit_rvalue *test = emit_mvar_val (arg0); + gcc_jit_block *target1 = retrive_block (THIRD (inst)); + gcc_jit_block *target2 = retrive_block (FORTH (inst)); + + emit_cond_jump (emit_NILP (test), target2, target1); + } else if (EQ (op, Qcall)) { gcc_jit_block_add_eval (comp.block, @@ -2091,6 +2100,7 @@ syms_of_comp (void) DEFSYM (Qsetimm, "setimm"); DEFSYM (Qreturn, "return"); DEFSYM (Qcomp_mvar, "comp-mvar"); + DEFSYM (Qcond_jump, "cond-jump"); defsubr (&Scomp_init_ctxt); defsubr (&Scomp_release_ctxt); commit e1d945421522f5b944b35e70cc0a535acc942230 Author: Andrea Corallo Date: Sun Jul 14 11:15:18 2019 +0200 basic funcall diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index ddebc295b4..20ea3d2fb3 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -314,7 +314,9 @@ If the calle function is known to have a return type propagate it." :constant arg) ,(comp-slot)))) (byte-varbind) - (byte-call) + (byte-call + (comp-stack-adjust (- arg)) + (comp-emit-set-call `(callref Ffuncall ,(1+ arg) ,(comp-sp)))) (byte-unbind) (byte-pophandler) (byte-pushconditioncase) diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index d3b2929abf..8f65ee6b53 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -141,64 +141,65 @@ (should (string= (comp-tests-concat-f "bar") "abcdabcabfoobar"))) -;; (ert-deftest comp-tests-ffuncall () -;; "Test calling conventions." -;; (defun comp-tests-ffuncall-callee-f (x y z) -;; (list x y z)) -;; (defun comp-tests-ffuncall-caller-f () -;; (comp-tests-ffuncall-callee-f 1 2 3)) +(ert-deftest comp-tests-ffuncall () + "Test calling conventions." + (defun comp-tests-ffuncall-callee-f (x y z) + (list x y z)) + (defun comp-tests-ffuncall-caller-f () + (comp-tests-ffuncall-callee-f 1 2 3)) -;; (native-compile #'comp-tests-ffuncall-caller-f) + (native-compile #'comp-tests-ffuncall-caller-f) -;; (should (equal (comp-tests-ffuncall-caller-f) '(1 2 3))) + (should (equal (comp-tests-ffuncall-caller-f) '(1 2 3))) -;; (defun comp-tests-ffuncall-callee-optional-f (a b &optional c d) -;; (list a b c d)) -;; (native-compile #'comp-tests-ffuncall-callee-optional-f) + ;; (defun comp-tests-ffuncall-callee-optional-f (a b &optional c d) + ;; (list a b c d)) + ;; (native-compile #'comp-tests-ffuncall-callee-optional-f) -;; (should (equal (comp-tests-ffuncall-callee-optional-f 1 2 3 4) '(1 2 3 4))) -;; (should (equal (comp-tests-ffuncall-callee-optional-f 1 2 3) '(1 2 3 nil))) -;; (should (equal (comp-tests-ffuncall-callee-optional-f 1 2) '(1 2 nil nil))) + ;; (should (equal (comp-tests-ffuncall-callee-optional-f 1 2 3 4) '(1 2 3 4))) + ;; (should (equal (comp-tests-ffuncall-callee-optional-f 1 2 3) '(1 2 3 nil))) + ;; (should (equal (comp-tests-ffuncall-callee-optional-f 1 2) '(1 2 nil nil))) -;; (defun comp-tests-ffuncall-callee-rest-f (a b &rest c) -;; (list a b c)) -;; (native-compile #'comp-tests-ffuncall-callee-rest-f) + ;; (defun comp-tests-ffuncall-callee-rest-f (a b &rest c) + ;; (list a b c)) + ;; (native-compile #'comp-tests-ffuncall-callee-rest-f) -;; (should (equal (comp-tests-ffuncall-callee-rest-f 1 2) '(1 2 nil))) -;; (should (equal (comp-tests-ffuncall-callee-rest-f 1 2 3) '(1 2 (3)))) -;; (should (equal (comp-tests-ffuncall-callee-rest-f 1 2 3 4) '(1 2 (3 4)))) + ;; (should (equal (comp-tests-ffuncall-callee-rest-f 1 2) '(1 2 nil))) + ;; (should (equal (comp-tests-ffuncall-callee-rest-f 1 2 3) '(1 2 (3)))) + ;; (should (equal (comp-tests-ffuncall-callee-rest-f 1 2 3 4) '(1 2 (3 4)))) -;; (defun comp-tests-ffuncall-native-f () -;; "Call a primitive with no dedicate op." -;; (make-vector 1 nil)) + ;; (defun comp-tests-ffuncall-native-f () + ;; "Call a primitive with no dedicate op." + ;; (make-vector 1 nil)) -;; (native-compile #'comp-tests-ffuncall-native-f) + ;; (native-compile #'comp-tests-ffuncall-native-f) -;; (should (equal (comp-tests-ffuncall-native-f) [nil])) + ;; (should (equal (comp-tests-ffuncall-native-f) [nil])) -;; (defun comp-tests-ffuncall-native-rest-f () -;; "Call a primitive with no dedicate op with &rest." -;; (vector 1 2 3)) + ;; (defun comp-tests-ffuncall-native-rest-f () + ;; "Call a primitive with no dedicate op with &rest." + ;; (vector 1 2 3)) -;; (native-compile #'comp-tests-ffuncall-native-rest-f) + ;; (native-compile #'comp-tests-ffuncall-native-rest-f) -;; (should (equal (comp-tests-ffuncall-native-rest-f) [1 2 3])) + ;; (should (equal (comp-tests-ffuncall-native-rest-f) [1 2 3])) -;; (defun comp-tests-ffuncall-apply-many-f (x) -;; (apply #'list x)) + ;; (defun comp-tests-ffuncall-apply-many-f (x) + ;; (apply #'list x)) -;; (native-compile #'comp-tests-ffuncall-apply-many-f) + ;; (native-compile #'comp-tests-ffuncall-apply-many-f) -;; (should (equal (comp-tests-ffuncall-apply-many-f '(1 2 3)) '(1 2 3))) + ;; (should (equal (comp-tests-ffuncall-apply-many-f '(1 2 3)) '(1 2 3))) -;; (defun comp-tests-ffuncall-lambda-f (x) -;; (let ((fun (lambda (x) -;; (1+ x)))) -;; (funcall fun x))) + ;; (defun comp-tests-ffuncall-lambda-f (x) + ;; (let ((fun (lambda (x) + ;; (1+ x)))) + ;; (funcall fun x))) -;; (native-compile #'comp-tests-ffuncall-lambda-f) + ;; (native-compile #'comp-tests-ffuncall-lambda-f) -;; (should (= (comp-tests-ffuncall-lambda-f 1) 2))) + ;; (should (= (comp-tests-ffuncall-lambda-f 1) 2)) + ) ;; (ert-deftest comp-tests-jump-table () ;; "Testing jump tables" commit ac297b67bb5fbd4488023ca693a1dc62f012da5d Author: Andrea Corallo Date: Sun Jul 14 10:57:46 2019 +0200 concat support diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 3c6ce6e582..ddebc295b4 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -297,18 +297,21 @@ If the calle function is known to have a return type propagate it." (defun comp-limplify-lap-inst (inst) "Limplify LAP instruction INST accumulating in `comp-limple'." - (let ((op (car inst))) + (let ((op (car inst)) + (arg (if (consp (cdr inst)) + (cadr inst) + (cdr inst)))) (comp-op-case (byte-stack-ref (comp-copy-slot-n (- (comp-sp) (cdr inst) 1))) (byte-varref (comp-emit-set-call `(call Fsymbol_value ,(make-comp-mvar :const-vld t - :constant (cadr inst))))) + :constant arg)))) (byte-varset (comp-emit `(call set_internal ,(make-comp-mvar :const-vld t - :constant (cadr inst)) + :constant arg) ,(comp-slot)))) (byte-varbind) (byte-call) @@ -356,9 +359,12 @@ If the calle function is known to have a return type propagate it." (byte-fset) (byte-get) (byte-substring) - (byte-concat2) - (byte-concat3) - (byte-concat4) + (byte-concat2 + (comp-emit-set-call `(callref Fconcat 2 ,(comp-sp)))) + (byte-concat3 + (comp-emit-set-call `(callref Fconcat 3 ,(comp-sp)))) + (byte-concat4 + (comp-emit-set-call `(callref Fconcat 4 ,(comp-sp)))) (byte-sub1) (byte-add1) (byte-eqlsign) @@ -411,8 +417,7 @@ If the calle function is known to have a return type propagate it." (byte-goto-if-nil-else-pop) (byte-goto-if-not-nil-else-pop) (byte-return - (comp-emit (list 'return (comp-slot-next))) - `(return ,(comp-slot-next))) + (comp-emit (list 'return (comp-slot-next)))) (byte-discard t) (byte-dup (comp-copy-slot-n (1- (comp-sp)))) @@ -450,14 +455,16 @@ If the calle function is known to have a return type propagate it." (byte-numberp) (byte-integerp) (byte-listN) - (byte-concatN) + (byte-concatN + (comp-stack-adjust (- (1- arg))) + (comp-emit-set-call `(callref Fconcat ,arg ,(comp-sp)))) (byte-insertN) (byte-stack-set) (byte-stack-set2) (byte-discardN) (byte-switch) (byte-constant - (comp-set-const (cadr inst)))))) + (comp-set-const arg))))) (defun comp-limplify (func) "Given FUNC and return compute its LIMPLE ir." diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 1030900752..d3b2929abf 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -132,14 +132,14 @@ (should (= (comp-tests-symbol-value-f) 3))) -;; (ert-deftest comp-tests-concat () -;; "Testing concatX opcodes." -;; (defun comp-tests-concat-f (x) -;; (concat "a" "b" "c" "d" -;; (concat "a" "b" "c" (concat "a" "b" (concat "foo" x))))) -;; (native-compile #'comp-tests-concat-f) - -;; (should (string= (comp-tests-concat-f "bar") "abcdabcabfoobar"))) +(ert-deftest comp-tests-concat () + "Testing concatX opcodes." + (defun comp-tests-concat-f (x) + (concat "a" "b" "c" "d" + (concat "a" "b" "c" (concat "a" "b" (concat "foo" x))))) + (native-compile #'comp-tests-concat-f) + + (should (string= (comp-tests-concat-f "bar") "abcdabcabfoobar"))) ;; (ert-deftest comp-tests-ffuncall () ;; "Test calling conventions." commit 210a3c0b3ad2a944bfed4e87a5039a9e4e14329a Author: Andrea Corallo Date: Sun Jul 14 09:53:06 2019 +0200 comp-op-case in place plus other rework diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 5731a00b2d..3c6ce6e582 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -54,6 +54,16 @@ ;; allocating memory? (these are technically not side effect free) ) +(eval-when-compile + (defconst comp-op-stack-info + (cl-loop with h = (make-hash-table) + for k across byte-code-vector + for v across byte-stack+-info + when k + do (puthash k v h) + finally return h) + "Hash table lap-op -> stack adjustment.")) + (cl-defstruct comp-args (min nil :type number :documentation "Minimum number of arguments allowed") @@ -183,8 +193,19 @@ To be used when ncall-conv is nil.") "Current stack pointer." '(comp-limple-frame-sp comp-frame)) +(defmacro comp-with-sp (sp &rest body) + "Execute BODY setting the stack pointer to SP. +Restore the original value afterwads." + (declare (debug (form body)) + (indent 1)) + `(let ((orig-sp (comp-sp))) + (setf (comp-sp) ,sp) + (progn ,@body) + (setf (comp-sp) orig-sp))) + (defmacro comp-slot-n (n) "Slot N into the meta-stack." + (declare (debug (form))) `(aref (comp-limple-frame-frame comp-frame) ,n)) (defmacro comp-slot () @@ -245,81 +266,198 @@ If the calle function is known to have a return type propagate it." (defun comp-limplify-listn (n) "Limplify list N." - (comp-emit-set-call `(call Fcons ,(comp-slot) - ,(make-comp-mvar :const-vld t - :constant nil))) - (dotimes (_ (1- n)) - (comp-stack-adjust -1) + (comp-with-sp (1- n) (comp-emit-set-call `(call Fcons - ,(comp-slot) - ,(comp-slot-n (1+ (comp-sp))))))) + ,(comp-slot) + ,(make-comp-mvar :const-vld t + :constant nil)))) + (cl-loop for sp from (+ (comp-sp) n -2) downto (comp-sp) + do (comp-with-sp sp + (comp-emit-set-call `(call Fcons + ,(comp-slot) + ,(comp-slot-next)))))) + +(defmacro comp-op-case (&rest cases) + "Expand CASES to the corresponding pcase." + (declare (debug (body)) + (indent defun)) + `(pcase op + ,@(cl-loop for (op . body) in cases + for sp-delta = (gethash op comp-op-stack-info) + for op-name = (symbol-name op) + if body + collect `(',op + (comp-emit-annotation ,(concat "LAP op " op-name)) + (comp-stack-adjust ,(if sp-delta sp-delta 0)) + (progn ,@body)) + else + collect `(',op (error ,(concat "Unsupported LAP op " + op-name)))) + (_ (error "Unexpected LAP op %s" (symbol-name op))))) (defun comp-limplify-lap-inst (inst) "Limplify LAP instruction INST accumulating in `comp-limple'." (let ((op (car inst))) - (pcase op - ('byte-discard - (comp-stack-adjust -1)) - ('byte-dup - (comp-stack-adjust 1) - (comp-copy-slot-n (1- (comp-sp)))) - ('byte-symbol-value - (comp-emit-set-call `(call Fsymbol_value ,(comp-slot)))) - ('byte-varref - (comp-stack-adjust 1) + (comp-op-case + (byte-stack-ref + (comp-copy-slot-n (- (comp-sp) (cdr inst) 1))) + (byte-varref (comp-emit-set-call `(call Fsymbol_value ,(make-comp-mvar :const-vld t :constant (cadr inst))))) - ('byte-varset + (byte-varset (comp-emit `(call set_internal ,(make-comp-mvar :const-vld t :constant (cadr inst)) ,(comp-slot)))) - ('byte-constant - (comp-stack-adjust 1) - (comp-set-const (cadr inst))) - ('byte-stack-ref - (comp-stack-adjust 1) - (comp-copy-slot-n (- (comp-sp) (cdr inst) 1))) - ('byte-plus - (comp-stack-adjust -1) - (comp-emit-set-call `(callref Fplus 2 ,(comp-sp)))) - ('byte-aref - (comp-stack-adjust -1) + (byte-varbind) + (byte-call) + (byte-unbind) + (byte-pophandler) + (byte-pushconditioncase) + (byte-pushcatch) + (byte-nth) + (byte-symbolp) + (byte-consp) + (byte-stringp) + (byte-listp) + (byte-eq) + (byte-memq) + (byte-not) + (byte-car + (comp-emit-set-call `(call Fcar ,(comp-slot)))) + (byte-cdr + (comp-emit-set-call `(call Fcdr ,(comp-slot)))) + (byte-cons + (comp-emit-set-call `(call Fcons ,(comp-slot) ,(comp-slot-next)))) + (byte-list1 + (comp-limplify-listn 1)) + (byte-list2 + (comp-limplify-listn 2)) + (byte-list3 + (comp-limplify-listn 3)) + (byte-list4 + (comp-limplify-listn 4)) + (byte-length + (comp-emit-set-call `(call Flength ,(comp-slot)))) + (byte-aref (comp-emit-set-call `(call Faref ,(comp-slot) ,(comp-slot-next)))) - ('byte-aset - (comp-stack-adjust -2) + (byte-aset (comp-emit-set-call `(call Faset ,(comp-slot) ,(comp-slot-next) ,(comp-slot-n (+ 2 (comp-sp)))))) - ('byte-cons - (comp-stack-adjust -1) - (comp-emit-set-call `(call Fcons ,(comp-slot) ,(comp-slot-next)))) - ('byte-car - (comp-emit-set-call `(call Fcar ,(comp-slot)))) - ('byte-cdr - (comp-emit-set-call `(call Fcdr ,(comp-slot)))) - ('byte-car-safe + (byte-symbol-value + (comp-emit-set-call `(call Fsymbol_value ,(comp-slot)))) + (byte-symbol-function) + (byte-set) + (byte-fset) + (byte-get) + (byte-substring) + (byte-concat2) + (byte-concat3) + (byte-concat4) + (byte-sub1) + (byte-add1) + (byte-eqlsign) + (byte-gtr) + (byte-lss) + (byte-leq) + (byte-geq) + (byte-diff) + (byte-negate) + (byte-plus + (comp-emit-set-call `(callref Fplus 2 ,(comp-sp)))) + (byte-max) + (byte-min) + (byte-mult) + (byte-point) + (byte-goto-char) + (byte-insert) + (byte-point-max) + (byte-point-min) + (byte-char-after) + (byte-following-char) + (byte-preceding-char) + (byte-current-column) + (byte-indent-to) + (byte-scan-buffer-OBSOLETE) + (byte-eolp) + (byte-eobp) + (byte-bolp) + (byte-bobp) + (byte-current-buffer) + (byte-set-buffer) + (byte-save-current-buffer) + (byte-set-mark-OBSOLETE) + (byte-interactive-p-OBSOLETE) + (byte-forward-char) + (byte-forward-word) + (byte-skip-chars-forward) + (byte-skip-chars-backward) + (byte-forward-line) + (byte-char-syntax) + (byte-buffer-substring) + (byte-delete-region) + (byte-narrow-to-region) + (byte-widen) + (byte-end-of-line) + (byte-constant2) + (byte-goto) + (byte-goto-if-nil) + (byte-goto-if-not-nil) + (byte-goto-if-nil-else-pop) + (byte-goto-if-not-nil-else-pop) + (byte-return + (comp-emit (list 'return (comp-slot-next))) + `(return ,(comp-slot-next))) + (byte-discard t) + (byte-dup + (comp-copy-slot-n (1- (comp-sp)))) + (byte-save-excursion) + (byte-save-window-excursion-OBSOLETE) + (byte-save-restriction) + (byte-catch) + (byte-unwind-protect) + (byte-condition-case) + (byte-temp-output-buffer-setup-OBSOLETE) + (byte-temp-output-buffer-show-OBSOLETE) + (byte-unbind-all) + (byte-set-marker) + (byte-match-beginning) + (byte-match-end) + (byte-upcase) + (byte-downcase) + (byte-string=) + (byte-string<) + (byte-equal) + (byte-nthcdr) + (byte-elt) + (byte-member) + (byte-assq) + (byte-nreverse) + (byte-setcar) + (byte-setcdr) + (byte-car-safe (comp-emit-set-call `(call Fcar_safe ,(comp-slot)))) - ('byte-cdr-safe + (byte-cdr-safe (comp-emit-set-call `(call Fcdr_safe ,(comp-slot)))) - ('byte-length - (comp-emit-set-call `(call Flength ,(comp-slot)))) - ('byte-list1 - (comp-limplify-listn 1)) - ('byte-list2 - (comp-limplify-listn 2)) - ('byte-list3 - (comp-limplify-listn 3)) - ('byte-list4 - (comp-limplify-listn 4)) - ('byte-return - (comp-emit (list 'return (comp-slot))) - `(return ,(comp-slot))) - (_ (error "Unexpected LAP op %s" (symbol-name op)))))) + (byte-nconc) + (byte-quo) + (byte-rem) + (byte-numberp) + (byte-integerp) + (byte-listN) + (byte-concatN) + (byte-insertN) + (byte-stack-set) + (byte-stack-set2) + (byte-discardN) + (byte-switch) + (byte-constant + (comp-set-const (cadr inst)))))) (defun comp-limplify (func) "Given FUNC and return compute its LIMPLE ir." commit 4a0379bdb41a6044978d0b5ffb2a5ece1984e404 Author: Andrea Corallo Date: Sat Jul 13 18:28:00 2019 +0200 reworking comp.el diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 2f3c689933..5731a00b2d 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -210,16 +210,10 @@ If the calle function is known to have a return type propagate it." comp-known-ret-types)))) (comp-emit (list 'set (comp-slot) call))) -(defun comp-push-call (call) - "Increase sp and call `comp-emit-set-call' to emit CALL." - (cl-incf (comp-sp)) - (comp-emit-set-call call)) - -(defun comp-push-slot-n (n) - "Push slot number N into frame." +(defun comp-copy-slot-n (n) + "Set current slot with slot number N as source." (let ((src-slot (comp-slot-n n))) (cl-assert src-slot) - (cl-incf (comp-sp)) (setf (comp-slot) (copy-sequence src-slot)) (setf (comp-mvar-slot (comp-slot)) (comp-sp)) @@ -229,10 +223,8 @@ If the calle function is known to have a return type propagate it." "Emit annotation STR." (comp-emit `(comment ,str))) -(defun comp-push-const (val) - "Push VAL into frame. -VAL is known at compile time." - (cl-incf (comp-sp)) +(defun comp-set-const (val) + "Set constant VAL to current slot." (setf (comp-slot) (make-comp-mvar :slot (comp-sp) :const-vld t :constant val)) @@ -247,9 +239,9 @@ VAL is known at compile time." (comp-limple-frame-new-frame (comp-func-frame-size comp-func))) (comp-emit `(block ,bblock))) -(defun comp-pop (n) - "Pop N elements from the meta-stack." - (cl-decf (comp-sp) n)) +(defun comp-stack-adjust (n) + "Move sp by N." + (cl-incf (comp-sp) n)) (defun comp-limplify-listn (n) "Limplify list N." @@ -257,7 +249,7 @@ VAL is known at compile time." ,(make-comp-mvar :const-vld t :constant nil))) (dotimes (_ (1- n)) - (comp-pop 1) + (comp-stack-adjust -1) (comp-emit-set-call `(call Fcons ,(comp-slot) ,(comp-slot-n (1+ (comp-sp))))))) @@ -267,40 +259,44 @@ VAL is known at compile time." (let ((op (car inst))) (pcase op ('byte-discard - (comp-pop 1)) + (comp-stack-adjust -1)) ('byte-dup - (comp-push-slot-n (comp-sp))) + (comp-stack-adjust 1) + (comp-copy-slot-n (1- (comp-sp)))) ('byte-symbol-value (comp-emit-set-call `(call Fsymbol_value ,(comp-slot)))) ('byte-varref - (comp-push-call `(call Fsymbol_value ,(make-comp-mvar - :const-vld t - :constant (cadr inst))))) + (comp-stack-adjust 1) + (comp-emit-set-call `(call Fsymbol_value ,(make-comp-mvar + :const-vld t + :constant (cadr inst))))) ('byte-varset (comp-emit `(call set_internal ,(make-comp-mvar :const-vld t :constant (cadr inst)) ,(comp-slot)))) ('byte-constant - (comp-push-const (cadr inst))) + (comp-stack-adjust 1) + (comp-set-const (cadr inst))) ('byte-stack-ref - (comp-push-slot-n (- (comp-sp) (cdr inst)))) + (comp-stack-adjust 1) + (comp-copy-slot-n (- (comp-sp) (cdr inst) 1))) ('byte-plus - (comp-pop 1) + (comp-stack-adjust -1) (comp-emit-set-call `(callref Fplus 2 ,(comp-sp)))) ('byte-aref - (comp-pop 1) + (comp-stack-adjust -1) (comp-emit-set-call `(call Faref ,(comp-slot) ,(comp-slot-next)))) ('byte-aset - (comp-pop 2) + (comp-stack-adjust -2) (comp-emit-set-call `(call Faset ,(comp-slot) ,(comp-slot-next) ,(comp-slot-n (+ 2 (comp-sp)))))) ('byte-cons - (comp-pop 1) + (comp-stack-adjust -1) (comp-emit-set-call `(call Fcons ,(comp-slot) ,(comp-slot-next)))) ('byte-car (comp-emit-set-call `(call Fcar ,(comp-slot)))) commit fdbdf3da7f0dc09bb04a919b1840652b327b64b4 Author: Andrea Corallo Date: Sat Jul 13 17:24:44 2019 +0200 symbol-value +1 test diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 712cade382..2f3c689933 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -37,6 +37,8 @@ (defconst comp-debug t) +(defvar comp-speed 2) + (defconst comp-passes '(comp-recuparate-lap comp-limplify) "Passes to be executed in order.") @@ -268,15 +270,16 @@ VAL is known at compile time." (comp-pop 1)) ('byte-dup (comp-push-slot-n (comp-sp))) + ('byte-symbol-value + (comp-emit-set-call `(call Fsymbol_value ,(comp-slot)))) ('byte-varref (comp-push-call `(call Fsymbol_value ,(make-comp-mvar :const-vld t :constant (cadr inst))))) ('byte-varset (comp-emit `(call set_internal - ,(make-comp-mvar - :const-vld t - :constant (cadr inst)) + ,(make-comp-mvar :const-vld t + :constant (cadr inst)) ,(comp-slot)))) ('byte-constant (comp-push-const (cadr inst))) diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 00bb2e0932..1030900752 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -123,14 +123,14 @@ (should (= (comp-tests-aref-aset-f) 100))) -;; (ert-deftest comp-tests-symbol-value () -;; "Testing aref and aset." -;; (defvar comp-tests-var2 3) -;; (defun comp-tests-symbol-value-f () -;; (symbol-value 'comp-tests-var2)) -;; (native-compile #'comp-tests-symbol-value-f) - -;; (should (= (comp-tests-symbol-value-f) 3))) +(ert-deftest comp-tests-symbol-value () + "Testing aref and aset." + (defvar comp-tests-var2 3) + (defun comp-tests-symbol-value-f () + (symbol-value 'comp-tests-var2)) + (native-compile #'comp-tests-symbol-value-f) + + (should (= (comp-tests-symbol-value-f) 3))) ;; (ert-deftest comp-tests-concat () ;; "Testing concatX opcodes." commit 2e20dca7a090b3821e78451f83930b689f5499c7 Author: Andrea Corallo Date: Sat Jul 13 17:08:15 2019 +0200 add discard aref aset diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 1094acf1ea..712cade382 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -198,12 +198,14 @@ To be used when ncall-conv is nil.") (push x comp-limple)) (defun comp-emit-set-call (call) - "Emit CALL assigning the result the the current slot frame.." + "Emit CALL assigning the result the the current slot frame. +If the calle function is known to have a return type propagate it." (cl-assert call) (setf (comp-slot) (make-comp-mvar :slot (comp-sp) - :type (alist-get (cadr call) - comp-known-ret-types))) + :type (when (> comp-speed 0) + (alist-get (cadr call) + comp-known-ret-types)))) (comp-emit (list 'set (comp-slot) call))) (defun comp-push-call (call) @@ -262,6 +264,8 @@ VAL is known at compile time." "Limplify LAP instruction INST accumulating in `comp-limple'." (let ((op (car inst))) (pcase op + ('byte-discard + (comp-pop 1)) ('byte-dup (comp-push-slot-n (comp-sp))) ('byte-varref @@ -281,6 +285,17 @@ VAL is known at compile time." ('byte-plus (comp-pop 1) (comp-emit-set-call `(callref Fplus 2 ,(comp-sp)))) + ('byte-aref + (comp-pop 1) + (comp-emit-set-call `(call Faref + ,(comp-slot) + ,(comp-slot-next)))) + ('byte-aset + (comp-pop 2) + (comp-emit-set-call `(call Faset + ,(comp-slot) + ,(comp-slot-next) + ,(comp-slot-n (+ 2 (comp-sp)))))) ('byte-cons (comp-pop 1) (comp-emit-set-call `(call Fcons ,(comp-slot) ,(comp-slot-next)))) diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 64edddf4c0..00bb2e0932 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -113,15 +113,15 @@ (should (= (comp-tests-length-f) 3))) -;; (ert-deftest comp-tests-aref-aset () -;; "Testing aref and aset." -;; (defun comp-tests-aref-aset-f () -;; (let ((vec [1 2 3])) -;; (aset vec 2 100) -;; (aref vec 2))) -;; (native-compile #'comp-tests-aref-aset-f) - -;; (should (= (comp-tests-aref-aset-f) 100))) +(ert-deftest comp-tests-aref-aset () + "Testing aref and aset." + (defun comp-tests-aref-aset-f () + (let ((vec [1 2 3])) + (aset vec 2 100) + (aref vec 2))) + (native-compile #'comp-tests-aref-aset-f) + + (should (= (comp-tests-aref-aset-f) 100))) ;; (ert-deftest comp-tests-symbol-value () ;; "Testing aref and aset." commit ba8ca065a7cde2f8221767ddb632b56eeefb29b5 Author: Andrea Corallo Date: Sat Jul 13 16:34:59 2019 +0200 let limple support calls with no assignment diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 05f17e43d6..1094acf1ea 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -193,19 +193,23 @@ To be used when ncall-conv is nil.") "Slot into the meta-stack pointed by sp + 1." '(comp-slot-n (1+ (comp-sp)))) -(defun comp-emit-call (call) - "Emit CALL." +(defun comp-emit (x) + "Emit X into current LIMPLE ir.." + (push x comp-limple)) + +(defun comp-emit-set-call (call) + "Emit CALL assigning the result the the current slot frame.." (cl-assert call) (setf (comp-slot) (make-comp-mvar :slot (comp-sp) :type (alist-get (cadr call) comp-known-ret-types))) - (push (list 'set (comp-slot) call) comp-limple)) + (comp-emit (list 'set (comp-slot) call))) (defun comp-push-call (call) - "Push call CALL into frame." + "Increase sp and call `comp-emit-set-call' to emit CALL." (cl-incf (comp-sp)) - (comp-emit-call call)) + (comp-emit-set-call call)) (defun comp-push-slot-n (n) "Push slot number N into frame." @@ -215,11 +219,11 @@ To be used when ncall-conv is nil.") (setf (comp-slot) (copy-sequence src-slot)) (setf (comp-mvar-slot (comp-slot)) (comp-sp)) - (push (list 'set (comp-slot) src-slot) comp-limple))) + (comp-emit (list 'set (comp-slot) src-slot)))) (defun comp-emit-annotation (str) "Emit annotation STR." - (push `(comment ,str) comp-limple)) + (comp-emit `(comment ,str))) (defun comp-push-const (val) "Push VAL into frame. @@ -228,7 +232,7 @@ VAL is known at compile time." (setf (comp-slot) (make-comp-mvar :slot (comp-sp) :const-vld t :constant val)) - (push (list 'setimm (comp-slot) val) comp-limple)) + (comp-emit (list 'setimm (comp-slot) val))) (defun comp-emit-block (bblock) "Push basic block BBLOCK." @@ -237,7 +241,7 @@ VAL is known at compile time." ;; This will be superseded by proper flow analysis. (setf (comp-limple-frame-frame comp-frame) (comp-limple-frame-new-frame (comp-func-frame-size comp-func))) - (push `(block ,bblock) comp-limple)) + (comp-emit `(block ,bblock))) (defun comp-pop (n) "Pop N elements from the meta-stack." @@ -245,12 +249,12 @@ VAL is known at compile time." (defun comp-limplify-listn (n) "Limplify list N." - (comp-emit-call `(call Fcons ,(comp-slot) + (comp-emit-set-call `(call Fcons ,(comp-slot) ,(make-comp-mvar :const-vld t :constant nil))) (dotimes (_ (1- n)) (comp-pop 1) - (comp-emit-call `(call Fcons + (comp-emit-set-call `(call Fcons ,(comp-slot) ,(comp-slot-n (1+ (comp-sp))))))) @@ -265,31 +269,31 @@ VAL is known at compile time." :const-vld t :constant (cadr inst))))) ('byte-varset - (comp-emit-call `(call set_internal - ,(make-comp-mvar - :const-vld t - :constant (cadr inst)) - ,(comp-slot)))) + (comp-emit `(call set_internal + ,(make-comp-mvar + :const-vld t + :constant (cadr inst)) + ,(comp-slot)))) ('byte-constant (comp-push-const (cadr inst))) ('byte-stack-ref (comp-push-slot-n (- (comp-sp) (cdr inst)))) ('byte-plus (comp-pop 1) - (comp-emit-call `(callref Fplus 2 ,(comp-sp)))) + (comp-emit-set-call `(callref Fplus 2 ,(comp-sp)))) ('byte-cons (comp-pop 1) - (comp-emit-call `(call Fcons ,(comp-slot) ,(comp-slot-next)))) + (comp-emit-set-call `(call Fcons ,(comp-slot) ,(comp-slot-next)))) ('byte-car - (comp-emit-call `(call Fcar ,(comp-slot)))) + (comp-emit-set-call `(call Fcar ,(comp-slot)))) ('byte-cdr - (comp-emit-call `(call Fcdr ,(comp-slot)))) + (comp-emit-set-call `(call Fcdr ,(comp-slot)))) ('byte-car-safe - (comp-emit-call `(call Fcar_safe ,(comp-slot)))) + (comp-emit-set-call `(call Fcar_safe ,(comp-slot)))) ('byte-cdr-safe - (comp-emit-call `(call Fcdr_safe ,(comp-slot)))) + (comp-emit-set-call `(call Fcdr_safe ,(comp-slot)))) ('byte-length - (comp-emit-call `(call Flength ,(comp-slot)))) + (comp-emit-set-call `(call Flength ,(comp-slot)))) ('byte-list1 (comp-limplify-listn 1)) ('byte-list2 @@ -299,7 +303,7 @@ VAL is known at compile time." ('byte-list4 (comp-limplify-listn 4)) ('byte-return - (push (list 'return (comp-slot)) comp-limple) + (comp-emit (list 'return (comp-slot))) `(return ,(comp-slot))) (_ (error "Unexpected LAP op %s" (symbol-name op)))))) diff --git a/src/comp.c b/src/comp.c index 25598aa20c..f164bf892a 100644 --- a/src/comp.c +++ b/src/comp.c @@ -976,12 +976,10 @@ emit_limple_call (Lisp_Object arg1) if (calle[0] == 'F') { /* - Ex: (= #s(comp-mvar 6 1 nil nil nil) - (call Fcar #s(comp-mvar 4 0 nil nil nil))) + Ex: (call Fcar #s(comp-mvar 4 0 nil nil nil)) - Ex: (= #s(comp-mvar 5 0 nil nil cons) - (call Fcons #s(comp-mvar 3 0 t 1 nil) - #s(comp-mvar 4 nil t nil nil))) + Ex: (call Fcons #s(comp-mvar 3 0 t 1 nil) + #s(comp-mvar 4 nil t nil nil)) */ ptrdiff_t nargs = list_length (call_args); @@ -994,10 +992,9 @@ emit_limple_call (Lisp_Object arg1) else if (!strcmp (calle, "set_internal")) { /* - Ex: (set #s(comp-mvar 8 1 nil nil nil) - (call set_internal - #s(comp-mvar 7 nil t xxx nil) - #s(comp-mvar 6 1 t 3 nil))) + Ex: (call set_internal + #s(comp-mvar 7 nil t xxx nil) + #s(comp-mvar 6 1 t 3 nil)) */ /* TODO: Inline the most common case. */ eassert (list_length (call_args) == 2); @@ -1008,14 +1005,26 @@ emit_limple_call (Lisp_Object arg1) gcc_args[3] = gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.int_type, SET_INTERNAL_SET); - gcc_jit_block_add_eval ( - comp.block, - NULL, - emit_call ("set_internal", comp.void_type , 4, gcc_args)); - - return NULL; + return emit_call ("set_internal", comp.void_type , 4, gcc_args); } - error ("LIMPLE inconsiste call"); + error ("LIMPLE call is inconsistet"); +} + +static gcc_jit_rvalue * +emit_limple_call_ref (Lisp_Object arg1) +{ + /* Ex: (callref Fplus 2 0). */ + + char *calle = (char *) SDATA (SYMBOL_NAME (SECOND (arg1))); + EMACS_UINT nargs = XFIXNUM (THIRD (arg1)); + EMACS_UINT base_ptr = XFIXNUM (FORTH (arg1)); + gcc_jit_rvalue *gcc_args[2] = + { gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.ptrdiff_type, + nargs), + gcc_jit_lvalue_get_address (comp.frame[base_ptr], NULL) }; + + return emit_call (calle, comp.lisp_obj_type, 2, gcc_args); } static void @@ -1032,53 +1041,35 @@ emit_limple_inst (Lisp_Object inst) } else if (EQ (op, Qjump)) { - /* Unconditional branch. */ + /* Unconditional branch. */ gcc_jit_block *target = retrive_block (arg0); gcc_jit_block_end_with_jump (comp.block, NULL, target); comp.block = target; } + else if (EQ (op, Qcall)) + { + gcc_jit_block_add_eval (comp.block, + NULL, + emit_limple_call (inst)); + } else if (EQ (op, Qset)) { EMACS_UINT slot_n = XFIXNUM (FUNCALL1 (comp-mvar-slot, arg0)); Lisp_Object arg1 = THIRD (inst); if (EQ (Ftype_of (arg1), Qcomp_mvar)) - { - /* - Ex: (= #s(comp-mvar 6 2 nil nil nil) - #s(comp-mvar 6 0 nil nil nil)). - */ - res = emit_mvar_val (arg1); - } + res = emit_mvar_val (arg1); else if (EQ (FIRST (arg1), Qcall)) - { - res = emit_limple_call (arg1); - } + res = emit_limple_call (arg1); else if (EQ (FIRST (arg1), Qcallref)) - { - /* Ex: (= #s(comp-mvar 10 1 nil nil nil) (callref Fplus 2 0)). */ - - char *calle = (char *) SDATA (SYMBOL_NAME (SECOND (arg1))); - EMACS_UINT nargs = XFIXNUM (THIRD (arg1)); - EMACS_UINT base_ptr = XFIXNUM (FORTH (arg1)); - gcc_jit_rvalue *gcc_args[2] = - { gcc_jit_context_new_rvalue_from_int (comp.ctxt, - comp.ptrdiff_type, - nargs), - gcc_jit_lvalue_get_address ( - comp.frame[base_ptr], - NULL) }; - res = emit_call (calle, comp.lisp_obj_type, 2, gcc_args); - } + res = emit_limple_call_ref (arg1); else - { - error ("LIMPLE inconsistent arg1 for op ="); - } - if (res) - gcc_jit_block_add_assignment (comp.block, - NULL, - comp.frame[slot_n], - res); + error ("LIMPLE inconsistent arg1 for op ="); + eassert (res); + gcc_jit_block_add_assignment (comp.block, + NULL, + comp.frame[slot_n], + res); } else if (EQ (op, Qsetpar)) { @@ -1105,7 +1096,7 @@ emit_limple_inst (Lisp_Object inst) } else if (EQ (op, Qcomment)) { - /* Ex: (comment "Function: foo"). */ + /* Ex: (comment "Function: foo"). */ emit_comment((char *) SDATA (arg0)); } else if (EQ (op, Qreturn)) commit 73cb29c3fb6d56f32f77ec201f9b61ac77e57290 Author: Andrea Corallo Date: Sat Jul 13 15:48:02 2019 +0200 varset support 5 test passing diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 68bc770ff9..05f17e43d6 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -20,6 +20,10 @@ ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs. If not, see . +;;; Commentary: +;; This code is an attempt to make a Carrera out of a turbocharged VW Bug. +;; Or, to put it another way to make the pig fly. + ;;; Code: (require 'bytecomp) @@ -260,8 +264,12 @@ VAL is known at compile time." (comp-push-call `(call Fsymbol_value ,(make-comp-mvar :const-vld t :constant (cadr inst))))) - ;; ('byte-varset - ;; (comp-emit-call `(call Fsymbol_value ,(cadr inst)))) + ('byte-varset + (comp-emit-call `(call set_internal + ,(make-comp-mvar + :const-vld t + :constant (cadr inst)) + ,(comp-slot)))) ('byte-constant (comp-push-const (cadr inst))) ('byte-stack-ref @@ -280,6 +288,8 @@ VAL is known at compile time." (comp-emit-call `(call Fcar_safe ,(comp-slot)))) ('byte-cdr-safe (comp-emit-call `(call Fcdr_safe ,(comp-slot)))) + ('byte-length + (comp-emit-call `(call Flength ,(comp-slot)))) ('byte-list1 (comp-limplify-listn 1)) ('byte-list2 diff --git a/src/comp.c b/src/comp.c index cbbc5f0378..25598aa20c 100644 --- a/src/comp.c +++ b/src/comp.c @@ -966,6 +966,58 @@ emit_mvar_val (Lisp_Object mvar) return emit_lisp_obj_from_ptr (FUNCALL1 (comp-mvar-constant, mvar)); } +static gcc_jit_rvalue * +emit_limple_call (Lisp_Object arg1) +{ + char *calle = (char *) SDATA (SYMBOL_NAME (SECOND (arg1))); + Lisp_Object call_args = XCDR (XCDR (arg1)); + int i = 0; + + if (calle[0] == 'F') + { + /* + Ex: (= #s(comp-mvar 6 1 nil nil nil) + (call Fcar #s(comp-mvar 4 0 nil nil nil))) + + Ex: (= #s(comp-mvar 5 0 nil nil cons) + (call Fcons #s(comp-mvar 3 0 t 1 nil) + #s(comp-mvar 4 nil t nil nil))) + */ + + ptrdiff_t nargs = list_length (call_args); + gcc_jit_rvalue *gcc_args[nargs]; + FOR_EACH_TAIL (call_args) + gcc_args[i++] = emit_mvar_val (XCAR (call_args)); + + return emit_call (calle, comp.lisp_obj_type, nargs, gcc_args); + } + else if (!strcmp (calle, "set_internal")) + { + /* + Ex: (set #s(comp-mvar 8 1 nil nil nil) + (call set_internal + #s(comp-mvar 7 nil t xxx nil) + #s(comp-mvar 6 1 t 3 nil))) + */ + /* TODO: Inline the most common case. */ + eassert (list_length (call_args) == 2); + gcc_jit_rvalue *gcc_args[4]; + FOR_EACH_TAIL (call_args) + gcc_args[i++] = emit_mvar_val (XCAR (call_args)); + gcc_args[2] = emit_lisp_obj_from_ptr (Qnil); + gcc_args[3] = gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.int_type, + SET_INTERNAL_SET); + gcc_jit_block_add_eval ( + comp.block, + NULL, + emit_call ("set_internal", comp.void_type , 4, gcc_args)); + + return NULL; + } + error ("LIMPLE inconsiste call"); +} + static void emit_limple_inst (Lisp_Object inst) { @@ -1000,23 +1052,7 @@ emit_limple_inst (Lisp_Object inst) } else if (EQ (FIRST (arg1), Qcall)) { - /* - Ex: (= #s(comp-mvar 6 1 nil nil nil) - (call Fcar #s(comp-mvar 4 0 nil nil nil))) - - Ex: (= #s(comp-mvar 5 0 nil nil cons) - (call Fcons #s(comp-mvar 3 0 t 1 nil) - #s(comp-mvar 4 nil t nil nil))) - */ - - char *calle = (char *) SDATA (SYMBOL_NAME (SECOND (arg1))); - Lisp_Object call_args = XCDR (XCDR (arg1)); - ptrdiff_t nargs = list_length (call_args); - gcc_jit_rvalue *gcc_args[nargs]; - int i = 0; - FOR_EACH_TAIL (call_args) - gcc_args[i++] = emit_mvar_val (XCAR (call_args)); - res = emit_call (calle, comp.lisp_obj_type, nargs, gcc_args); + res = emit_limple_call (arg1); } else if (EQ (FIRST (arg1), Qcallref)) { @@ -1038,10 +1074,11 @@ emit_limple_inst (Lisp_Object inst) { error ("LIMPLE inconsistent arg1 for op ="); } - gcc_jit_block_add_assignment (comp.block, - NULL, - comp.frame[slot_n], - res); + if (res) + gcc_jit_block_add_assignment (comp.block, + NULL, + comp.frame[slot_n], + res); } else if (EQ (op, Qsetpar)) { diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 0aea66f974..64edddf4c0 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -95,23 +95,23 @@ (should (= (comp-tests-cons-car-f) 1)) (should (= (comp-tests-cons-cdr-f 3) 3))) -;; (ert-deftest comp-tests-varset () -;; "Testing varset." -;; (defun comp-tests-varset-f () -;; (setq comp-tests-var1 55)) -;; (native-compile #'comp-tests-varset-f) +(ert-deftest comp-tests-varset () + "Testing varset." + (defun comp-tests-varset-f () + (setq comp-tests-var1 55)) + (native-compile #'comp-tests-varset-f) -;; (comp-tests-varset-f) + (comp-tests-varset-f) -;; (should (= comp-tests-var1 55))) + (should (= comp-tests-var1 55))) -;; (ert-deftest comp-tests-length () -;; "Testing length." -;; (defun comp-tests-length-f () -;; (length '(1 2 3))) -;; (native-compile #'comp-tests-length-f) +(ert-deftest comp-tests-length () + "Testing length." + (defun comp-tests-length-f () + (length '(1 2 3))) + (native-compile #'comp-tests-length-f) -;; (should (= (comp-tests-length-f) 3))) + (should (= (comp-tests-length-f) 3))) ;; (ert-deftest comp-tests-aref-aset () ;; "Testing aref and aset." commit 973a7b149f1362c4201d38bffeabbf857e7bb6d5 Author: Andrea Corallo Date: Sat Jul 13 11:33:15 2019 +0200 some consistency rework one test + diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 0270788e21..68bc770ff9 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -189,15 +189,19 @@ To be used when ncall-conv is nil.") "Slot into the meta-stack pointed by sp + 1." '(comp-slot-n (1+ (comp-sp)))) -(defun comp-push-call (src-slot) - "Push call SRC-SLOT into frame." - (cl-assert src-slot) - (cl-incf (comp-sp)) +(defun comp-emit-call (call) + "Emit CALL." + (cl-assert call) (setf (comp-slot) (make-comp-mvar :slot (comp-sp) - :type (alist-get (cadr src-slot) + :type (alist-get (cadr call) comp-known-ret-types))) - (push (list 'set (comp-slot) src-slot) comp-limple)) + (push (list 'set (comp-slot) call) comp-limple)) + +(defun comp-push-call (call) + "Push call CALL into frame." + (cl-incf (comp-sp)) + (comp-emit-call call)) (defun comp-push-slot-n (n) "Push slot number N into frame." @@ -222,7 +226,7 @@ VAL is known at compile time." :constant val)) (push (list 'setimm (comp-slot) val) comp-limple)) -(defun comp-push-block (bblock) +(defun comp-emit-block (bblock) "Push basic block BBLOCK." (push bblock (comp-func-blocks comp-func)) ;; Every new block we are forced to wipe out all the frame. @@ -237,15 +241,14 @@ VAL is known at compile time." (defun comp-limplify-listn (n) "Limplify list N." - (comp-pop 1) - (comp-push-call `(call Fcons ,(comp-slot-next) + (comp-emit-call `(call Fcons ,(comp-slot) ,(make-comp-mvar :const-vld t :constant nil))) (dotimes (_ (1- n)) - (comp-pop 2) - (comp-push-call `(call Fcons - ,(comp-slot-next) - ,(comp-slot-n (+ 2 (comp-sp))))))) + (comp-pop 1) + (comp-emit-call `(call Fcons + ,(comp-slot) + ,(comp-slot-n (1+ (comp-sp))))))) (defun comp-limplify-lap-inst (inst) "Limplify LAP instruction INST accumulating in `comp-limple'." @@ -258,26 +261,25 @@ VAL is known at compile time." :const-vld t :constant (cadr inst))))) ;; ('byte-varset - ;; (comp-push-call `(call Fsymbol_value ,(cadr inst)))) + ;; (comp-emit-call `(call Fsymbol_value ,(cadr inst)))) ('byte-constant (comp-push-const (cadr inst))) ('byte-stack-ref (comp-push-slot-n (- (comp-sp) (cdr inst)))) ('byte-plus - (comp-pop 2) - (comp-push-call `(callref Fplus 2 ,(comp-sp)))) - ('byte-car (comp-pop 1) - (comp-push-call `(call Fcar ,(comp-slot)))) - ('byte-cdr + (comp-emit-call `(callref Fplus 2 ,(comp-sp)))) + ('byte-cons (comp-pop 1) - (comp-push-call `(call Fcdr ,(comp-slot)))) + (comp-emit-call `(call Fcons ,(comp-slot) ,(comp-slot-next)))) + ('byte-car + (comp-emit-call `(call Fcar ,(comp-slot)))) + ('byte-cdr + (comp-emit-call `(call Fcdr ,(comp-slot)))) ('byte-car-safe - (comp-pop 1) - (comp-push-call `(call Fcar_safe ,(comp-slot)))) + (comp-emit-call `(call Fcar_safe ,(comp-slot)))) ('byte-cdr-safe - (comp-pop 1) - (comp-push-call `(call Fcdr_safe ,(comp-slot)))) + (comp-emit-call `(call Fcdr_safe ,(comp-slot)))) ('byte-list1 (comp-limplify-listn 1)) ('byte-list2 @@ -300,7 +302,7 @@ VAL is known at compile time." :frame (comp-limple-frame-new-frame frame-size))) (comp-limple ())) ;; Prologue - (comp-push-block 'entry) + (comp-emit-block 'entry) (comp-emit-annotation (concat "Lisp function: " (symbol-name (comp-func-symbol-name func)))) (cl-loop for i below (comp-args-mandatory (comp-func-args func)) @@ -309,7 +311,7 @@ VAL is known at compile time." (push `(setpar ,(comp-slot) ,i) comp-limple))) (push '(jump body) comp-limple) ;; Body - (comp-push-block 'body) + (comp-emit-block 'body) (mapc #'comp-limplify-lap-inst (comp-func-ir func)) (setf (comp-func-ir func) (reverse comp-limple)) ;; Prologue block must be first diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index a8445c79c8..0aea66f974 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -82,18 +82,18 @@ (should (= (comp-tests-cdr-safe-f '(1 . 2)) 2)) (should (null (comp-tests-cdr-safe-f 'a)))) -;; (ert-deftest comp-tests-cons-car-cdr () -;; "Testing cons car cdr." -;; (defun comp-tests-cons-car-f () -;; (car (cons 1 2))) -;; (native-compile #'comp-tests-cons-car-f) +(ert-deftest comp-tests-cons-car-cdr () + "Testing cons car cdr." + (defun comp-tests-cons-car-f () + (car (cons 1 2))) + (native-compile #'comp-tests-cons-car-f) -;; (defun comp-tests-cons-cdr-f (x) -;; (cdr (cons 'foo x))) -;; (native-compile #'comp-tests-cons-cdr-f) + (defun comp-tests-cons-cdr-f (x) + (cdr (cons 'foo x))) + (native-compile #'comp-tests-cons-cdr-f) -;; (should (= (comp-tests-cons-car-f) 1)) -;; (should (= (comp-tests-cons-cdr-f 3) 3))) + (should (= (comp-tests-cons-car-f) 1)) + (should (= (comp-tests-cons-cdr-f 3) 3))) ;; (ert-deftest comp-tests-varset () ;; "Testing varset." commit 8f1492c0b7b3ca684b3f88dc709b882cb758aad3 Author: Andrea Corallo Date: Thu Jul 11 22:39:42 2019 +0200 simplify limple instruction set diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index bac1c6af69..0270788e21 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -197,7 +197,7 @@ To be used when ncall-conv is nil.") (make-comp-mvar :slot (comp-sp) :type (alist-get (cadr src-slot) comp-known-ret-types))) - (push (list '=call (comp-slot) src-slot) comp-limple)) + (push (list 'set (comp-slot) src-slot) comp-limple)) (defun comp-push-slot-n (n) "Push slot number N into frame." @@ -207,7 +207,7 @@ To be used when ncall-conv is nil.") (setf (comp-slot) (copy-sequence src-slot)) (setf (comp-mvar-slot (comp-slot)) (comp-sp)) - (push (list '=slot (comp-slot) src-slot) comp-limple))) + (push (list 'set (comp-slot) src-slot) comp-limple))) (defun comp-emit-annotation (str) "Emit annotation STR." @@ -220,7 +220,7 @@ VAL is known at compile time." (setf (comp-slot) (make-comp-mvar :slot (comp-sp) :const-vld t :constant val)) - (push (list '=const (comp-slot) val) comp-limple)) + (push (list 'setimm (comp-slot) val) comp-limple)) (defun comp-push-block (bblock) "Push basic block BBLOCK." @@ -306,7 +306,7 @@ VAL is known at compile time." (cl-loop for i below (comp-args-mandatory (comp-func-args func)) do (progn (cl-incf (comp-sp)) - (push `(=par ,(comp-slot) ,i) comp-limple))) + (push `(setpar ,(comp-slot) ,i) comp-limple))) (push '(jump body) comp-limple) ;; Body (comp-push-block 'body) diff --git a/src/comp.c b/src/comp.c index 1d6eaf6648..cbbc5f0378 100644 --- a/src/comp.c +++ b/src/comp.c @@ -951,12 +951,12 @@ emit_PURE_P (gcc_jit_rvalue *ptr) /* return emit_call (f_name, comp.lisp_obj_type, 2, args); */ /* } */ -/* Retrive an r-value from a meta variable. +/* Emit an r-value from an mvar meta variable. In case this is a constant that was propagated return it otherwise load it - from the frame. */ + from frame. */ static gcc_jit_rvalue * -retrive_mvar_val (Lisp_Object mvar) +emit_mvar_val (Lisp_Object mvar) { if (NILP (FUNCALL1 (comp-mvar-const-vld, mvar))) return @@ -971,6 +971,7 @@ emit_limple_inst (Lisp_Object inst) { Lisp_Object op = XCAR (inst); Lisp_Object arg0 = SECOND (inst); + gcc_jit_rvalue *res; if (EQ (op, Qblock)) { @@ -984,40 +985,43 @@ emit_limple_inst (Lisp_Object inst) gcc_jit_block_end_with_jump (comp.block, NULL, target); comp.block = target; } - else if (EQ (op, Qcall_ass)) + else if (EQ (op, Qset)) { - /* - Ex: (=call #s(comp-mvar 6 1 nil nil nil) - (call Fcar #s(comp-mvar 4 0 nil nil nil))) - - Ex: (=call #s(comp-mvar 5 0 nil nil cons) - (call Fcons #s(comp-mvar 3 0 t 1 nil) - #s(comp-mvar 4 nil t nil nil))) - */ EMACS_UINT slot_n = XFIXNUM (FUNCALL1 (comp-mvar-slot, arg0)); Lisp_Object arg1 = THIRD (inst); - if (FIRST (arg1) == Qcall) + if (EQ (Ftype_of (arg1), Qcomp_mvar)) { - char *calle = (char *) SDATA (SYMBOL_NAME (SECOND (arg1))); + /* + Ex: (= #s(comp-mvar 6 2 nil nil nil) + #s(comp-mvar 6 0 nil nil nil)). + */ + res = emit_mvar_val (arg1); + } + else if (EQ (FIRST (arg1), Qcall)) + { + /* + Ex: (= #s(comp-mvar 6 1 nil nil nil) + (call Fcar #s(comp-mvar 4 0 nil nil nil))) + + Ex: (= #s(comp-mvar 5 0 nil nil cons) + (call Fcons #s(comp-mvar 3 0 t 1 nil) + #s(comp-mvar 4 nil t nil nil))) + */ + char *calle = (char *) SDATA (SYMBOL_NAME (SECOND (arg1))); Lisp_Object call_args = XCDR (XCDR (arg1)); ptrdiff_t nargs = list_length (call_args); gcc_jit_rvalue *gcc_args[nargs]; int i = 0; FOR_EACH_TAIL (call_args) - gcc_args[i++] = retrive_mvar_val (XCAR (call_args)); - gcc_jit_rvalue *res = - emit_call (calle, comp.lisp_obj_type, nargs, gcc_args); - - gcc_jit_block_add_assignment (comp.block, - NULL, - comp.frame[slot_n], - res); + gcc_args[i++] = emit_mvar_val (XCAR (call_args)); + res = emit_call (calle, comp.lisp_obj_type, nargs, gcc_args); } - else if ((FIRST (arg1) == Qcallref)) + else if (EQ (FIRST (arg1), Qcallref)) { - /* Ex: (=call #s(comp-mvar 10 1 nil nil nil) (callref Fplus 2 0)). */ + /* Ex: (= #s(comp-mvar 10 1 nil nil nil) (callref Fplus 2 0)). */ + char *calle = (char *) SDATA (SYMBOL_NAME (SECOND (arg1))); EMACS_UINT nargs = XFIXNUM (THIRD (arg1)); EMACS_UINT base_ptr = XFIXNUM (FORTH (arg1)); @@ -1028,17 +1032,18 @@ emit_limple_inst (Lisp_Object inst) gcc_jit_lvalue_get_address ( comp.frame[base_ptr], NULL) }; - gcc_jit_rvalue *res = - emit_call (calle, comp.lisp_obj_type, 2, gcc_args); - gcc_jit_block_add_assignment (comp.block, - NULL, - comp.frame[slot_n], - res); + res = emit_call (calle, comp.lisp_obj_type, 2, gcc_args); } else - error ("LIMPLE inconsistent arg1 for op =call"); + { + error ("LIMPLE inconsistent arg1 for op ="); + } + gcc_jit_block_add_assignment (comp.block, + NULL, + comp.frame[slot_n], + res); } - else if (EQ (op, Qpar_ass)) + else if (EQ (op, Qsetpar)) { /* Ex: (=par #s(comp-mvar 2 0 nil nil nil) 0). */ EMACS_UINT slot_n = XFIXNUM (FUNCALL1 (comp-mvar-slot, arg0)); @@ -1051,9 +1056,9 @@ emit_limple_inst (Lisp_Object inst) comp.frame[slot_n], param); } - else if (EQ (op, Qconst_ass)) + else if (EQ (op, Qsetimm)) { - /* EX: (=const #s(comp-mvar 9 1 t 3 nil) 3). */ + /* EX: (=imm #s(comp-mvar 9 1 t 3 nil) 3). */ Lisp_Object arg1 = THIRD (inst); EMACS_UINT slot_n = XFIXNUM (FUNCALL1 (comp-mvar-slot, arg0)); gcc_jit_block_add_assignment (comp.block, @@ -1070,7 +1075,7 @@ emit_limple_inst (Lisp_Object inst) { gcc_jit_block_end_with_return (comp.block, NULL, - retrive_mvar_val (arg0)); + emit_mvar_val (arg0)); } } @@ -2054,10 +2059,10 @@ syms_of_comp (void) DEFSYM (Qcall, "call"); DEFSYM (Qcallref, "callref"); DEFSYM (Qncall, "ncall"); - DEFSYM (Qpar_ass, "=par"); - DEFSYM (Qcall_ass, "=call"); - DEFSYM (Qconst_ass, "=const"); + DEFSYM (Qsetpar, "setpar"); + DEFSYM (Qsetimm, "setimm"); DEFSYM (Qreturn, "return"); + DEFSYM (Qcomp_mvar, "comp-mvar"); defsubr (&Scomp_init_ctxt); defsubr (&Scomp_release_ctxt); commit 6d0d29cae64051e61393be8f1ad1187e218cad40 Author: Andrea Corallo Date: Thu Jul 11 22:10:21 2019 +0200 call ref works diff --git a/src/comp.c b/src/comp.c index fe868def11..1d6eaf6648 100644 --- a/src/comp.c +++ b/src/comp.c @@ -43,6 +43,8 @@ along with GNU Emacs. If not, see . */ XCAR (XCDR (x)) #define THIRD(x) \ XCAR (XCDR (XCDR (x))) +#define FORTH(x) \ + XCAR (XCDR (XCDR (XCDR (x)))) #define FUNCALL1(fun, arg) \ CALLN (Ffuncall, intern (STR(fun)), arg) @@ -994,7 +996,7 @@ emit_limple_inst (Lisp_Object inst) */ EMACS_UINT slot_n = XFIXNUM (FUNCALL1 (comp-mvar-slot, arg0)); Lisp_Object arg1 = THIRD (inst); - eassert (FIRST (arg1) == Qcall); + if (FIRST (arg1) == Qcall) { char *calle = (char *) SDATA (SYMBOL_NAME (SECOND (arg1))); @@ -1013,8 +1015,28 @@ emit_limple_inst (Lisp_Object inst) comp.frame[slot_n], res); } + else if ((FIRST (arg1) == Qcallref)) + { + /* Ex: (=call #s(comp-mvar 10 1 nil nil nil) (callref Fplus 2 0)). */ + char *calle = (char *) SDATA (SYMBOL_NAME (SECOND (arg1))); + EMACS_UINT nargs = XFIXNUM (THIRD (arg1)); + EMACS_UINT base_ptr = XFIXNUM (FORTH (arg1)); + gcc_jit_rvalue *gcc_args[2] = + { gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.ptrdiff_type, + nargs), + gcc_jit_lvalue_get_address ( + comp.frame[base_ptr], + NULL) }; + gcc_jit_rvalue *res = + emit_call (calle, comp.lisp_obj_type, 2, gcc_args); + gcc_jit_block_add_assignment (comp.block, + NULL, + comp.frame[slot_n], + res); + } else - eassert (false); + error ("LIMPLE inconsistent arg1 for op =call"); } else if (EQ (op, Qpar_ass)) { @@ -1031,6 +1053,13 @@ emit_limple_inst (Lisp_Object inst) } else if (EQ (op, Qconst_ass)) { + /* EX: (=const #s(comp-mvar 9 1 t 3 nil) 3). */ + Lisp_Object arg1 = THIRD (inst); + EMACS_UINT slot_n = XFIXNUM (FUNCALL1 (comp-mvar-slot, arg0)); + gcc_jit_block_add_assignment (comp.block, + NULL, + comp.frame[slot_n], + emit_lisp_obj_from_ptr (arg1)); } else if (EQ (op, Qcomment)) { @@ -2023,6 +2052,7 @@ syms_of_comp (void) DEFSYM (Qblock, "block"); DEFSYM (Qjump, "jump"); DEFSYM (Qcall, "call"); + DEFSYM (Qcallref, "callref"); DEFSYM (Qncall, "ncall"); DEFSYM (Qpar_ass, "=par"); DEFSYM (Qcall_ass, "=call"); diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 1d00dea219..a8445c79c8 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -64,7 +64,7 @@ (native-compile #'comp-tests-car-safe-f) (native-compile #'comp-tests-cdr-safe-f) - ;; (should (equal (comp-tests-list-f) '(1 2 3))) + (should (equal (comp-tests-list-f) '(1 2 3))) (should (= (comp-tests-car-f '(1 . 2)) 1)) (should (null (comp-tests-car-f nil))) (should (= (condition-case err commit 749f4ce51f5f7348b9804e83d995a7ec22205727 Author: Andrea Corallo Date: Wed Jul 10 21:29:32 2019 +0200 improve function name translation diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 077e7a1eb3..bac1c6af69 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -108,6 +108,7 @@ To be used when ncall-conv is nil.") (defun comp-c-func-name (symbol-function) "Given SYMBOL-FUNCTION return a name suitable for the native code." ;; Unfortunatelly not all symbol names are valid as C function names... + ;; Nassi's algorithm. (let* ((orig-name (symbol-name symbol-function)) (crypted (cl-loop with str = (make-string (* 2 (length orig-name)) 0) for j from 0 by 2 @@ -117,7 +118,9 @@ To be used when ncall-conv is nil.") do (aset str (1+ j) (aref byte 1)) finally return str)) (human-readable (replace-regexp-in-string - (rx (not (any "a-z"))) "" orig-name))) + "-" "_" orig-name)) + (human-readable (replace-regexp-in-string + (rx (not (any "a-z_"))) "" human-readable))) (concat "F" crypted "_" human-readable))) (defun comp-decrypt-lambda-list (x) @@ -298,7 +301,7 @@ VAL is known at compile time." (comp-limple ())) ;; Prologue (comp-push-block 'entry) - (comp-emit-annotation (concat "Function: " + (comp-emit-annotation (concat "Lisp function: " (symbol-name (comp-func-symbol-name func)))) (cl-loop for i below (comp-args-mandatory (comp-func-args func)) do (progn commit c81aba08e3285d7864c60ea121959972a8584f35 Author: Andrea Corallo Date: Wed Jul 10 21:19:40 2019 +0200 fix list diff --git a/src/comp.c b/src/comp.c index d6e09226cd..fe868def11 100644 --- a/src/comp.c +++ b/src/comp.c @@ -984,20 +984,37 @@ emit_limple_inst (Lisp_Object inst) } else if (EQ (op, Qcall_ass)) { - /* Ex: (=call #s(comp-mvar 6 1 nil nil nil) - (call Fcar #s(comp-mvar 4 0 nil nil nil))). */ + /* + Ex: (=call #s(comp-mvar 6 1 nil nil nil) + (call Fcar #s(comp-mvar 4 0 nil nil nil))) + + Ex: (=call #s(comp-mvar 5 0 nil nil cons) + (call Fcons #s(comp-mvar 3 0 t 1 nil) + #s(comp-mvar 4 nil t nil nil))) + */ EMACS_UINT slot_n = XFIXNUM (FUNCALL1 (comp-mvar-slot, arg0)); Lisp_Object arg1 = THIRD (inst); eassert (FIRST (arg1) == Qcall); - char *calle = (char *) SDATA (SYMBOL_NAME (SECOND (arg1))); - gcc_jit_rvalue *args[] = - { retrive_mvar_val (THIRD (arg1)) }; - gcc_jit_rvalue *res = emit_call (calle, comp.lisp_obj_type, 1, args); - - gcc_jit_block_add_assignment (comp.block, - NULL, - comp.frame[slot_n], - res); + if (FIRST (arg1) == Qcall) + { + char *calle = (char *) SDATA (SYMBOL_NAME (SECOND (arg1))); + + Lisp_Object call_args = XCDR (XCDR (arg1)); + ptrdiff_t nargs = list_length (call_args); + gcc_jit_rvalue *gcc_args[nargs]; + int i = 0; + FOR_EACH_TAIL (call_args) + gcc_args[i++] = retrive_mvar_val (XCAR (call_args)); + gcc_jit_rvalue *res = + emit_call (calle, comp.lisp_obj_type, nargs, gcc_args); + + gcc_jit_block_add_assignment (comp.block, + NULL, + comp.frame[slot_n], + res); + } + else + eassert (false); } else if (EQ (op, Qpar_ass)) { diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 33f5ebfdc2..1d00dea219 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -43,8 +43,8 @@ (ert-deftest comp-tests-list () "Testing cons car cdr." - ;; (defun comp-tests-list-f () - ;; (list 1 2 3)) + (defun comp-tests-list-f () + (list 1 2 3)) (defun comp-tests-car-f (x) ;; Bcar (car x)) @@ -58,7 +58,7 @@ ;; Bcdr_safe (cdr-safe x)) - ;; (native-compile #'comp-tests-list-f) + (native-compile #'comp-tests-list-f) (native-compile #'comp-tests-car-f) (native-compile #'comp-tests-cdr-f) (native-compile #'comp-tests-car-safe-f) commit 65918ebff8ed764a3dcfb3d7f4c95a4cb854b0f7 Author: Andrea Corallo Date: Wed Jul 10 18:55:19 2019 +0200 function name as annotation diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 934c76f842..077e7a1eb3 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -206,6 +206,10 @@ To be used when ncall-conv is nil.") (setf (comp-mvar-slot (comp-slot)) (comp-sp)) (push (list '=slot (comp-slot) src-slot) comp-limple))) +(defun comp-emit-annotation (str) + "Emit annotation STR." + (push `(comment ,str) comp-limple)) + (defun comp-push-const (val) "Push VAL into frame. VAL is known at compile time." @@ -294,6 +298,8 @@ VAL is known at compile time." (comp-limple ())) ;; Prologue (comp-push-block 'entry) + (comp-emit-annotation (concat "Function: " + (symbol-name (comp-func-symbol-name func)))) (cl-loop for i below (comp-args-mandatory (comp-func-args func)) do (progn (cl-incf (comp-sp)) diff --git a/src/comp.c b/src/comp.c index 1a74605934..d6e09226cd 100644 --- a/src/comp.c +++ b/src/comp.c @@ -982,7 +982,7 @@ emit_limple_inst (Lisp_Object inst) gcc_jit_block_end_with_jump (comp.block, NULL, target); comp.block = target; } - else if (EQ (op, Q_call_ass)) + else if (EQ (op, Qcall_ass)) { /* Ex: (=call #s(comp-mvar 6 1 nil nil nil) (call Fcar #s(comp-mvar 4 0 nil nil nil))). */ @@ -999,7 +999,7 @@ emit_limple_inst (Lisp_Object inst) comp.frame[slot_n], res); } - else if (EQ (op, Q_par_ass)) + else if (EQ (op, Qpar_ass)) { /* Ex: (=par #s(comp-mvar 2 0 nil nil nil) 0). */ EMACS_UINT slot_n = XFIXNUM (FUNCALL1 (comp-mvar-slot, arg0)); @@ -1012,9 +1012,14 @@ emit_limple_inst (Lisp_Object inst) comp.frame[slot_n], param); } - else if (EQ (op, Q_const_ass)) + else if (EQ (op, Qconst_ass)) { } + else if (EQ (op, Qcomment)) + { + /* Ex: (comment "Function: foo"). */ + emit_comment((char *) SDATA (arg0)); + } else if (EQ (op, Qreturn)) { gcc_jit_block_end_with_return (comp.block, @@ -1997,13 +2002,14 @@ void syms_of_comp (void) { /* Limple instruction set. */ + DEFSYM (Qcomment, "comment"); DEFSYM (Qblock, "block"); DEFSYM (Qjump, "jump"); DEFSYM (Qcall, "call"); DEFSYM (Qncall, "ncall"); - DEFSYM (Q_par_ass, "=par"); - DEFSYM (Q_call_ass, "=call"); - DEFSYM (Q_const_ass, "=const"); + DEFSYM (Qpar_ass, "=par"); + DEFSYM (Qcall_ass, "=call"); + DEFSYM (Qconst_ass, "=const"); DEFSYM (Qreturn, "return"); defsubr (&Scomp_init_ctxt); commit 0bd54f29cbf264e0982d3b31b4c313329ae26a27 Author: Andrea Corallo Date: Wed Jul 10 03:06:21 2019 +0200 two test passing diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index fe5a0694ee..934c76f842 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -247,7 +247,9 @@ VAL is known at compile time." ('byte-dup (comp-push-slot-n (comp-sp))) ('byte-varref - (comp-push-call `(call Fsymbol_value ,(cadr inst)))) + (comp-push-call `(call Fsymbol_value ,(make-comp-mvar + :const-vld t + :constant (cadr inst))))) ;; ('byte-varset ;; (comp-push-call `(call Fsymbol_value ,(cadr inst)))) ('byte-constant @@ -259,16 +261,16 @@ VAL is known at compile time." (comp-push-call `(callref Fplus 2 ,(comp-sp)))) ('byte-car (comp-pop 1) - (comp-push-call `(call Fcar ,(comp-sp)))) + (comp-push-call `(call Fcar ,(comp-slot)))) ('byte-cdr (comp-pop 1) - (comp-push-call `(call Fcdr ,(comp-sp)))) + (comp-push-call `(call Fcdr ,(comp-slot)))) ('byte-car-safe (comp-pop 1) - (comp-push-call `(call Fcar-safe ,(comp-sp)))) + (comp-push-call `(call Fcar_safe ,(comp-slot)))) ('byte-cdr-safe (comp-pop 1) - (comp-push-call `(call Fcdr-safe ,(comp-sp)))) + (comp-push-call `(call Fcdr_safe ,(comp-slot)))) ('byte-list1 (comp-limplify-listn 1)) ('byte-list2 diff --git a/src/comp.c b/src/comp.c index a52aa242c0..1a74605934 100644 --- a/src/comp.c +++ b/src/comp.c @@ -984,12 +984,14 @@ emit_limple_inst (Lisp_Object inst) } else if (EQ (op, Q_call_ass)) { + /* Ex: (=call #s(comp-mvar 6 1 nil nil nil) + (call Fcar #s(comp-mvar 4 0 nil nil nil))). */ EMACS_UINT slot_n = XFIXNUM (FUNCALL1 (comp-mvar-slot, arg0)); Lisp_Object arg1 = THIRD (inst); eassert (FIRST (arg1) == Qcall); char *calle = (char *) SDATA (SYMBOL_NAME (SECOND (arg1))); gcc_jit_rvalue *args[] = - { emit_lisp_obj_from_ptr (THIRD (arg1)) }; + { retrive_mvar_val (THIRD (arg1)) }; gcc_jit_rvalue *res = emit_call (calle, comp.lisp_obj_type, 1, args); gcc_jit_block_add_assignment (comp.block, diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 8d3a0f507d..33f5ebfdc2 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -32,23 +32,19 @@ (defvar comp-tests-var1 3) -(defun comp-test-compile (f) - ;; (byte-compile f) - (native-compile f)) - (ert-deftest comp-tests-varref () "Testing varref." (defun comp-tests-varref-f () comp-tests-var1) - (comp-test-compile #'comp-tests-varref-f) + (native-compile #'comp-tests-varref-f) (should (= (comp-tests-varref-f) 3))) -(ert-deftest comp-tests-list () +(ert-deftest comp-tests-list () "Testing cons car cdr." - (defun comp-tests-list-f () - (list 1 2 3)) + ;; (defun comp-tests-list-f () + ;; (list 1 2 3)) (defun comp-tests-car-f (x) ;; Bcar (car x)) @@ -62,13 +58,13 @@ ;; Bcdr_safe (cdr-safe x)) - (comp-test-compile #'comp-tests-list-f) - (comp-test-compile #'comp-tests-car-f) - (comp-test-compile #'comp-tests-cdr-f) - (comp-test-compile #'comp-tests-car-safe-f) - (comp-test-compile #'comp-tests-cdr-safe-f) + ;; (native-compile #'comp-tests-list-f) + (native-compile #'comp-tests-car-f) + (native-compile #'comp-tests-cdr-f) + (native-compile #'comp-tests-car-safe-f) + (native-compile #'comp-tests-cdr-safe-f) - (should (equal (comp-tests-list-f) '(1 2 3))) + ;; (should (equal (comp-tests-list-f) '(1 2 3))) (should (= (comp-tests-car-f '(1 . 2)) 1)) (should (null (comp-tests-car-f nil))) (should (= (condition-case err @@ -86,396 +82,396 @@ (should (= (comp-tests-cdr-safe-f '(1 . 2)) 2)) (should (null (comp-tests-cdr-safe-f 'a)))) -(ert-deftest comp-tests-cons-car-cdr () - "Testing cons car cdr." - (defun comp-tests-cons-car-f () - (car (cons 1 2))) - (comp-test-compile #'comp-tests-cons-car-f) +;; (ert-deftest comp-tests-cons-car-cdr () +;; "Testing cons car cdr." +;; (defun comp-tests-cons-car-f () +;; (car (cons 1 2))) +;; (native-compile #'comp-tests-cons-car-f) - (defun comp-tests-cons-cdr-f (x) - (cdr (cons 'foo x))) - (comp-test-compile #'comp-tests-cons-cdr-f) +;; (defun comp-tests-cons-cdr-f (x) +;; (cdr (cons 'foo x))) +;; (native-compile #'comp-tests-cons-cdr-f) - (should (= (comp-tests-cons-car-f) 1)) - (should (= (comp-tests-cons-cdr-f 3) 3))) +;; (should (= (comp-tests-cons-car-f) 1)) +;; (should (= (comp-tests-cons-cdr-f 3) 3))) -(ert-deftest comp-tests-varset () - "Testing varset." - (defun comp-tests-varset-f () - (setq comp-tests-var1 55)) - (comp-test-compile #'comp-tests-varset-f) +;; (ert-deftest comp-tests-varset () +;; "Testing varset." +;; (defun comp-tests-varset-f () +;; (setq comp-tests-var1 55)) +;; (native-compile #'comp-tests-varset-f) - (comp-tests-varset-f) +;; (comp-tests-varset-f) - (should (= comp-tests-var1 55))) +;; (should (= comp-tests-var1 55))) -(ert-deftest comp-tests-length () - "Testing length." - (defun comp-tests-length-f () - (length '(1 2 3))) - (comp-test-compile #'comp-tests-length-f) +;; (ert-deftest comp-tests-length () +;; "Testing length." +;; (defun comp-tests-length-f () +;; (length '(1 2 3))) +;; (native-compile #'comp-tests-length-f) - (should (= (comp-tests-length-f) 3))) +;; (should (= (comp-tests-length-f) 3))) -(ert-deftest comp-tests-aref-aset () - "Testing aref and aset." - (defun comp-tests-aref-aset-f () - (let ((vec [1 2 3])) - (aset vec 2 100) - (aref vec 2))) - (comp-test-compile #'comp-tests-aref-aset-f) +;; (ert-deftest comp-tests-aref-aset () +;; "Testing aref and aset." +;; (defun comp-tests-aref-aset-f () +;; (let ((vec [1 2 3])) +;; (aset vec 2 100) +;; (aref vec 2))) +;; (native-compile #'comp-tests-aref-aset-f) - (should (= (comp-tests-aref-aset-f) 100))) +;; (should (= (comp-tests-aref-aset-f) 100))) -(ert-deftest comp-tests-symbol-value () - "Testing aref and aset." - (defvar comp-tests-var2 3) - (defun comp-tests-symbol-value-f () - (symbol-value 'comp-tests-var2)) - (comp-test-compile #'comp-tests-symbol-value-f) +;; (ert-deftest comp-tests-symbol-value () +;; "Testing aref and aset." +;; (defvar comp-tests-var2 3) +;; (defun comp-tests-symbol-value-f () +;; (symbol-value 'comp-tests-var2)) +;; (native-compile #'comp-tests-symbol-value-f) - (should (= (comp-tests-symbol-value-f) 3))) +;; (should (= (comp-tests-symbol-value-f) 3))) -(ert-deftest comp-tests-concat () - "Testing concatX opcodes." - (defun comp-tests-concat-f (x) - (concat "a" "b" "c" "d" - (concat "a" "b" "c" (concat "a" "b" (concat "foo" x))))) - (comp-test-compile #'comp-tests-concat-f) +;; (ert-deftest comp-tests-concat () +;; "Testing concatX opcodes." +;; (defun comp-tests-concat-f (x) +;; (concat "a" "b" "c" "d" +;; (concat "a" "b" "c" (concat "a" "b" (concat "foo" x))))) +;; (native-compile #'comp-tests-concat-f) - (should (string= (comp-tests-concat-f "bar") "abcdabcabfoobar"))) - -(ert-deftest comp-tests-ffuncall () - "Test calling conventions." - (defun comp-tests-ffuncall-callee-f (x y z) - (list x y z)) - (defun comp-tests-ffuncall-caller-f () - (comp-tests-ffuncall-callee-f 1 2 3)) - - (comp-test-compile #'comp-tests-ffuncall-caller-f) - - (should (equal (comp-tests-ffuncall-caller-f) '(1 2 3))) - - (defun comp-tests-ffuncall-callee-optional-f (a b &optional c d) - (list a b c d)) - (comp-test-compile #'comp-tests-ffuncall-callee-optional-f) - - (should (equal (comp-tests-ffuncall-callee-optional-f 1 2 3 4) '(1 2 3 4))) - (should (equal (comp-tests-ffuncall-callee-optional-f 1 2 3) '(1 2 3 nil))) - (should (equal (comp-tests-ffuncall-callee-optional-f 1 2) '(1 2 nil nil))) - - (defun comp-tests-ffuncall-callee-rest-f (a b &rest c) - (list a b c)) - (comp-test-compile #'comp-tests-ffuncall-callee-rest-f) - - (should (equal (comp-tests-ffuncall-callee-rest-f 1 2) '(1 2 nil))) - (should (equal (comp-tests-ffuncall-callee-rest-f 1 2 3) '(1 2 (3)))) - (should (equal (comp-tests-ffuncall-callee-rest-f 1 2 3 4) '(1 2 (3 4)))) - - (defun comp-tests-ffuncall-native-f () - "Call a primitive with no dedicate op." - (make-vector 1 nil)) - - (comp-test-compile #'comp-tests-ffuncall-native-f) - - (should (equal (comp-tests-ffuncall-native-f) [nil])) - - (defun comp-tests-ffuncall-native-rest-f () - "Call a primitive with no dedicate op with &rest." - (vector 1 2 3)) - - (comp-test-compile #'comp-tests-ffuncall-native-rest-f) - - (should (equal (comp-tests-ffuncall-native-rest-f) [1 2 3])) - - (defun comp-tests-ffuncall-apply-many-f (x) - (apply #'list x)) - - (comp-test-compile #'comp-tests-ffuncall-apply-many-f) - - (should (equal (comp-tests-ffuncall-apply-many-f '(1 2 3)) '(1 2 3))) - - (defun comp-tests-ffuncall-lambda-f (x) - (let ((fun (lambda (x) - (1+ x)))) - (funcall fun x))) - - (comp-test-compile #'comp-tests-ffuncall-lambda-f) - - (should (= (comp-tests-ffuncall-lambda-f 1) 2))) - -(ert-deftest comp-tests-jump-table () - "Testing jump tables" - (defun comp-tests-jump-table-1-f (x) - (pcase x - ('x 'a) - ('y 'b) - (_ 'c))) - - - (should (eq (comp-tests-jump-table-1-f 'x) 'a)) - (should (eq (comp-tests-jump-table-1-f 'y) 'b)) - (should (eq (comp-tests-jump-table-1-f 'xxx) 'c))) - -(ert-deftest comp-tests-conditionals () - "Testing conditionals." - (defun comp-tests-conditionals-1-f (x) - ;; Generate goto-if-nil - (if x 1 2)) - (defun comp-tests-conditionals-2-f (x) - ;; Generate goto-if-nil-else-pop - (when x - 1340)) - (comp-test-compile #'comp-tests-conditionals-1-f) - (comp-test-compile #'comp-tests-conditionals-2-f) - - (should (= (comp-tests-conditionals-1-f t) 1)) - (should (= (comp-tests-conditionals-1-f nil) 2)) - (should (= (comp-tests-conditionals-2-f t) 1340)) - (should (eq (comp-tests-conditionals-2-f nil) nil))) - -(ert-deftest comp-tests-fixnum () - "Testing some fixnum inline operation." - (defun comp-tests-fixnum-1-minus-f (x) - ;; Bsub1 - (1- x)) - (defun comp-tests-fixnum-1-plus-f (x) - ;; Badd1 - (1+ x)) - (defun comp-tests-fixnum-minus-f (x) - ;; Bnegate - (- x)) - - (comp-test-compile #'comp-tests-fixnum-1-minus-f) - (comp-test-compile #'comp-tests-fixnum-1-plus-f) - (comp-test-compile #'comp-tests-fixnum-minus-f) - - (should (= (comp-tests-fixnum-1-minus-f 10) 9)) - (should (= (comp-tests-fixnum-1-minus-f most-negative-fixnum) - (1- most-negative-fixnum))) - (should (equal (condition-case err - (comp-tests-fixnum-1-minus-f 'a) - (error err)) - '(wrong-type-argument number-or-marker-p a))) - (should (= (comp-tests-fixnum-1-plus-f 10) 11)) - (should (= (comp-tests-fixnum-1-plus-f most-positive-fixnum) - (1+ most-positive-fixnum))) - (should (equal (condition-case err - (comp-tests-fixnum-1-plus-f 'a) - (error err)) - '(wrong-type-argument number-or-marker-p a))) - (should (= (comp-tests-fixnum-minus-f 10) -10)) - (should (= (comp-tests-fixnum-minus-f most-negative-fixnum) - (- most-negative-fixnum))) - (should (equal (condition-case err - (comp-tests-fixnum-minus-f 'a) - (error err)) - '(wrong-type-argument number-or-marker-p a)))) - -(ert-deftest comp-tests-arith-comp () - "Testing arithmetic comparisons." - (defun comp-tests-eqlsign-f (x y) - ;; Beqlsign - (= x y)) - (defun comp-tests-gtr-f (x y) - ;; Bgtr - (> x y)) - (defun comp-tests-lss-f (x y) - ;; Blss - (< x y)) - (defun comp-tests-les-f (x y) - ;; Bleq - (<= x y)) - (defun comp-tests-geq-f (x y) - ;; Bgeq - (>= x y)) - - - (comp-test-compile #'comp-tests-eqlsign-f) - (comp-test-compile #'comp-tests-gtr-f) - (comp-test-compile #'comp-tests-lss-f) - (comp-test-compile #'comp-tests-les-f) - (comp-test-compile #'comp-tests-geq-f) - - (should (eq (comp-tests-eqlsign-f 4 3) nil)) - (should (eq (comp-tests-eqlsign-f 3 3) t)) - (should (eq (comp-tests-eqlsign-f 2 3) nil)) - (should (eq (comp-tests-gtr-f 4 3) t)) - (should (eq (comp-tests-gtr-f 3 3) nil)) - (should (eq (comp-tests-gtr-f 2 3) nil)) - (should (eq (comp-tests-lss-f 4 3) nil)) - (should (eq (comp-tests-lss-f 3 3) nil)) - (should (eq (comp-tests-lss-f 2 3) t)) - (should (eq (comp-tests-les-f 4 3) nil)) - (should (eq (comp-tests-les-f 3 3) t)) - (should (eq (comp-tests-les-f 2 3) t)) - (should (eq (comp-tests-geq-f 4 3) t)) - (should (eq (comp-tests-geq-f 3 3) t)) - (should (eq (comp-tests-geq-f 2 3) nil))) - -(ert-deftest comp-tests-setcarcdr () - "Testing setcar setcdr." - (defun comp-tests-setcar-f (x y) - (setcar x y) - x) - (defun comp-tests-setcdr-f (x y) - (setcdr x y) - x) - - (comp-test-compile #'comp-tests-setcar-f) - (comp-test-compile #'comp-tests-setcdr-f) - - (should (equal (comp-tests-setcar-f '(10 . 10) 3) '(3 . 10))) - (should (equal (comp-tests-setcdr-f '(10 . 10) 3) '(10 . 3))) - (should (equal (condition-case - err - (comp-tests-setcar-f 3 10) - (error err)) - '(wrong-type-argument consp 3))) - (should (equal (condition-case - err - (comp-tests-setcdr-f 3 10) - (error err)) - '(wrong-type-argument consp 3)))) - -(ert-deftest comp-tests-bubble-sort () - "Run bubble sort." - (defun comp-bubble-sort-f (list) - (let ((i (length list))) - (while (> i 1) - (let ((b list)) - (while (cdr b) - (when (< (cadr b) (car b)) - (setcar b (prog1 (cadr b) - (setcdr b (cons (car b) (cddr b)))))) - (setq b (cdr b)))) - (setq i (1- i))) - list)) - - (comp-test-compile #'comp-bubble-sort-f) - - (let* ((list1 (mapcar 'random (make-list 1000 most-positive-fixnum))) - (list2 (copy-sequence list1))) - (should (equal (comp-bubble-sort-f list1) - (sort list2 #'<))))) - -(ert-deftest comp-tests-list-inline () - "Test some inlined list functions." - (defun comp-tests-consp-f (x) - ;; Bconsp - (consp x)) - (defun comp-tests-car-f (x) - ;; Bsetcar - (setcar x 3)) - - (comp-test-compile #'comp-tests-consp-f) - (comp-test-compile #'comp-tests-car-f) - - (should (eq (comp-tests-consp-f '(1)) t)) - (should (eq (comp-tests-consp-f 1) nil)) - (let ((x (cons 1 2))) - (should (= (comp-tests-car-f x) 3)) - (should (equal x '(3 . 2))))) - -(ert-deftest comp-tests-num-inline () - "Test some inlined number functions." - (defun comp-tests-integerp-f (x) - ;; Bintegerp - (integerp x)) - (defun comp-tests-numberp-f (x) - ;; Bnumberp - (numberp x)) - - (comp-test-compile #'comp-tests-integerp-f) - (comp-test-compile #'comp-tests-numberp-f) - - (should (eq (comp-tests-integerp-f 1) t)) - (should (eq (comp-tests-integerp-f '(1)) nil)) - (should (eq (comp-tests-integerp-f 3.5) nil)) - (should (eq (comp-tests-integerp-f (1+ most-negative-fixnum)) t)) - - (should (eq (comp-tests-numberp-f 1) t)) - (should (eq (comp-tests-numberp-f 'a) nil)) - (should (eq (comp-tests-numberp-f 3.5) t))) - -(ert-deftest comp-tests-stack () - "Test some stack operation." - (defun comp-tests-discardn-f (x) - ;; BdiscardN - (1+ (let ((a 1) - (_b) - (_c)) - a))) - (defun comp-tests-insertn-f (a b c d) - ;; Binsert - (insert a b c d)) - - (comp-test-compile #'comp-tests-discardn-f) - (comp-test-compile #'comp-tests-insertn-f) - - (should (= (comp-tests-discardn-f 10) 2)) - - (should (string= (with-temp-buffer - (comp-tests-insertn-f "a" "b" "c" "d") - (buffer-string)) - "abcd"))) - -(ert-deftest comp-tests-non-locals () - "Test non locals." - (defun comp-tests-err-arith-f () - (/ 1 0)) - (defun comp-tests-err-foo-f () - (error "foo")) - - (defun comp-tests-condition-case-0-f () - ;; Bpushhandler Bpophandler - (condition-case - err - (comp-tests-err-arith-f) - (arith-error (concat "arith-error " - (error-message-string err) - " catched")) - (error (concat "error " - (error-message-string err) - " catched")))) - - (defun comp-tests-condition-case-1-f () - ;; Bpushhandler Bpophandler - (condition-case - err - (comp-tests-err-foo-f) - (arith-error (concat "arith-error " - (error-message-string err) - " catched")) - (error (concat "error " - (error-message-string err) - " catched")))) - - (defun comp-tests-catch-f (f) - (catch 'foo - (funcall f))) - - (defun comp-tests-throw-f (x) - (throw 'foo x)) - - (comp-test-compile #'comp-tests-condition-case-0-f) - (comp-test-compile #'comp-tests-condition-case-1-f) - (comp-test-compile #'comp-tests-catch-f) - (comp-test-compile #'comp-tests-throw-f) - - (should (string= (comp-tests-condition-case-0-f) - "arith-error Arithmetic error catched")) - (should (string= (comp-tests-condition-case-1-f) - "error foo catched")) - (should (= (comp-tests-catch-f (lambda () (throw 'foo 3))) 3)) - (should (= (catch 'foo - (comp-tests-throw-f 3))))) - -(ert-deftest comp-tests-gc () - "Try to do some longer computation to let the gc kick in." - (dotimes (_ 100000) - (comp-tests-cons-cdr-f 3)) - - (should (= (comp-tests-cons-cdr-f 3) 3))) +;; (should (string= (comp-tests-concat-f "bar") "abcdabcabfoobar"))) + +;; (ert-deftest comp-tests-ffuncall () +;; "Test calling conventions." +;; (defun comp-tests-ffuncall-callee-f (x y z) +;; (list x y z)) +;; (defun comp-tests-ffuncall-caller-f () +;; (comp-tests-ffuncall-callee-f 1 2 3)) + +;; (native-compile #'comp-tests-ffuncall-caller-f) + +;; (should (equal (comp-tests-ffuncall-caller-f) '(1 2 3))) + +;; (defun comp-tests-ffuncall-callee-optional-f (a b &optional c d) +;; (list a b c d)) +;; (native-compile #'comp-tests-ffuncall-callee-optional-f) + +;; (should (equal (comp-tests-ffuncall-callee-optional-f 1 2 3 4) '(1 2 3 4))) +;; (should (equal (comp-tests-ffuncall-callee-optional-f 1 2 3) '(1 2 3 nil))) +;; (should (equal (comp-tests-ffuncall-callee-optional-f 1 2) '(1 2 nil nil))) + +;; (defun comp-tests-ffuncall-callee-rest-f (a b &rest c) +;; (list a b c)) +;; (native-compile #'comp-tests-ffuncall-callee-rest-f) + +;; (should (equal (comp-tests-ffuncall-callee-rest-f 1 2) '(1 2 nil))) +;; (should (equal (comp-tests-ffuncall-callee-rest-f 1 2 3) '(1 2 (3)))) +;; (should (equal (comp-tests-ffuncall-callee-rest-f 1 2 3 4) '(1 2 (3 4)))) + +;; (defun comp-tests-ffuncall-native-f () +;; "Call a primitive with no dedicate op." +;; (make-vector 1 nil)) + +;; (native-compile #'comp-tests-ffuncall-native-f) + +;; (should (equal (comp-tests-ffuncall-native-f) [nil])) + +;; (defun comp-tests-ffuncall-native-rest-f () +;; "Call a primitive with no dedicate op with &rest." +;; (vector 1 2 3)) + +;; (native-compile #'comp-tests-ffuncall-native-rest-f) + +;; (should (equal (comp-tests-ffuncall-native-rest-f) [1 2 3])) + +;; (defun comp-tests-ffuncall-apply-many-f (x) +;; (apply #'list x)) + +;; (native-compile #'comp-tests-ffuncall-apply-many-f) + +;; (should (equal (comp-tests-ffuncall-apply-many-f '(1 2 3)) '(1 2 3))) + +;; (defun comp-tests-ffuncall-lambda-f (x) +;; (let ((fun (lambda (x) +;; (1+ x)))) +;; (funcall fun x))) + +;; (native-compile #'comp-tests-ffuncall-lambda-f) + +;; (should (= (comp-tests-ffuncall-lambda-f 1) 2))) + +;; (ert-deftest comp-tests-jump-table () +;; "Testing jump tables" +;; (defun comp-tests-jump-table-1-f (x) +;; (pcase x +;; ('x 'a) +;; ('y 'b) +;; (_ 'c))) + + +;; (should (eq (comp-tests-jump-table-1-f 'x) 'a)) +;; (should (eq (comp-tests-jump-table-1-f 'y) 'b)) +;; (should (eq (comp-tests-jump-table-1-f 'xxx) 'c))) + +;; (ert-deftest comp-tests-conditionals () +;; "Testing conditionals." +;; (defun comp-tests-conditionals-1-f (x) +;; ;; Generate goto-if-nil +;; (if x 1 2)) +;; (defun comp-tests-conditionals-2-f (x) +;; ;; Generate goto-if-nil-else-pop +;; (when x +;; 1340)) +;; (native-compile #'comp-tests-conditionals-1-f) +;; (native-compile #'comp-tests-conditionals-2-f) + +;; (should (= (comp-tests-conditionals-1-f t) 1)) +;; (should (= (comp-tests-conditionals-1-f nil) 2)) +;; (should (= (comp-tests-conditionals-2-f t) 1340)) +;; (should (eq (comp-tests-conditionals-2-f nil) nil))) + +;; (ert-deftest comp-tests-fixnum () +;; "Testing some fixnum inline operation." +;; (defun comp-tests-fixnum-1-minus-f (x) +;; ;; Bsub1 +;; (1- x)) +;; (defun comp-tests-fixnum-1-plus-f (x) +;; ;; Badd1 +;; (1+ x)) +;; (defun comp-tests-fixnum-minus-f (x) +;; ;; Bnegate +;; (- x)) + +;; (native-compile #'comp-tests-fixnum-1-minus-f) +;; (native-compile #'comp-tests-fixnum-1-plus-f) +;; (native-compile #'comp-tests-fixnum-minus-f) + +;; (should (= (comp-tests-fixnum-1-minus-f 10) 9)) +;; (should (= (comp-tests-fixnum-1-minus-f most-negative-fixnum) +;; (1- most-negative-fixnum))) +;; (should (equal (condition-case err +;; (comp-tests-fixnum-1-minus-f 'a) +;; (error err)) +;; '(wrong-type-argument number-or-marker-p a))) +;; (should (= (comp-tests-fixnum-1-plus-f 10) 11)) +;; (should (= (comp-tests-fixnum-1-plus-f most-positive-fixnum) +;; (1+ most-positive-fixnum))) +;; (should (equal (condition-case err +;; (comp-tests-fixnum-1-plus-f 'a) +;; (error err)) +;; '(wrong-type-argument number-or-marker-p a))) +;; (should (= (comp-tests-fixnum-minus-f 10) -10)) +;; (should (= (comp-tests-fixnum-minus-f most-negative-fixnum) +;; (- most-negative-fixnum))) +;; (should (equal (condition-case err +;; (comp-tests-fixnum-minus-f 'a) +;; (error err)) +;; '(wrong-type-argument number-or-marker-p a)))) + +;; (ert-deftest comp-tests-arith-comp () +;; "Testing arithmetic comparisons." +;; (defun comp-tests-eqlsign-f (x y) +;; ;; Beqlsign +;; (= x y)) +;; (defun comp-tests-gtr-f (x y) +;; ;; Bgtr +;; (> x y)) +;; (defun comp-tests-lss-f (x y) +;; ;; Blss +;; (< x y)) +;; (defun comp-tests-les-f (x y) +;; ;; Bleq +;; (<= x y)) +;; (defun comp-tests-geq-f (x y) +;; ;; Bgeq +;; (>= x y)) + + +;; (native-compile #'comp-tests-eqlsign-f) +;; (native-compile #'comp-tests-gtr-f) +;; (native-compile #'comp-tests-lss-f) +;; (native-compile #'comp-tests-les-f) +;; (native-compile #'comp-tests-geq-f) + +;; (should (eq (comp-tests-eqlsign-f 4 3) nil)) +;; (should (eq (comp-tests-eqlsign-f 3 3) t)) +;; (should (eq (comp-tests-eqlsign-f 2 3) nil)) +;; (should (eq (comp-tests-gtr-f 4 3) t)) +;; (should (eq (comp-tests-gtr-f 3 3) nil)) +;; (should (eq (comp-tests-gtr-f 2 3) nil)) +;; (should (eq (comp-tests-lss-f 4 3) nil)) +;; (should (eq (comp-tests-lss-f 3 3) nil)) +;; (should (eq (comp-tests-lss-f 2 3) t)) +;; (should (eq (comp-tests-les-f 4 3) nil)) +;; (should (eq (comp-tests-les-f 3 3) t)) +;; (should (eq (comp-tests-les-f 2 3) t)) +;; (should (eq (comp-tests-geq-f 4 3) t)) +;; (should (eq (comp-tests-geq-f 3 3) t)) +;; (should (eq (comp-tests-geq-f 2 3) nil))) + +;; (ert-deftest comp-tests-setcarcdr () +;; "Testing setcar setcdr." +;; (defun comp-tests-setcar-f (x y) +;; (setcar x y) +;; x) +;; (defun comp-tests-setcdr-f (x y) +;; (setcdr x y) +;; x) + +;; (native-compile #'comp-tests-setcar-f) +;; (native-compile #'comp-tests-setcdr-f) + +;; (should (equal (comp-tests-setcar-f '(10 . 10) 3) '(3 . 10))) +;; (should (equal (comp-tests-setcdr-f '(10 . 10) 3) '(10 . 3))) +;; (should (equal (condition-case +;; err +;; (comp-tests-setcar-f 3 10) +;; (error err)) +;; '(wrong-type-argument consp 3))) +;; (should (equal (condition-case +;; err +;; (comp-tests-setcdr-f 3 10) +;; (error err)) +;; '(wrong-type-argument consp 3)))) + +;; (ert-deftest comp-tests-bubble-sort () +;; "Run bubble sort." +;; (defun comp-bubble-sort-f (list) +;; (let ((i (length list))) +;; (while (> i 1) +;; (let ((b list)) +;; (while (cdr b) +;; (when (< (cadr b) (car b)) +;; (setcar b (prog1 (cadr b) +;; (setcdr b (cons (car b) (cddr b)))))) +;; (setq b (cdr b)))) +;; (setq i (1- i))) +;; list)) + +;; (native-compile #'comp-bubble-sort-f) + +;; (let* ((list1 (mapcar 'random (make-list 1000 most-positive-fixnum))) +;; (list2 (copy-sequence list1))) +;; (should (equal (comp-bubble-sort-f list1) +;; (sort list2 #'<))))) + +;; (ert-deftest comp-tests-list-inline () +;; "Test some inlined list functions." +;; (defun comp-tests-consp-f (x) +;; ;; Bconsp +;; (consp x)) +;; (defun comp-tests-car-f (x) +;; ;; Bsetcar +;; (setcar x 3)) + +;; (native-compile #'comp-tests-consp-f) +;; (native-compile #'comp-tests-car-f) + +;; (should (eq (comp-tests-consp-f '(1)) t)) +;; (should (eq (comp-tests-consp-f 1) nil)) +;; (let ((x (cons 1 2))) +;; (should (= (comp-tests-car-f x) 3)) +;; (should (equal x '(3 . 2))))) + +;; (ert-deftest comp-tests-num-inline () +;; "Test some inlined number functions." +;; (defun comp-tests-integerp-f (x) +;; ;; Bintegerp +;; (integerp x)) +;; (defun comp-tests-numberp-f (x) +;; ;; Bnumberp +;; (numberp x)) + +;; (native-compile #'comp-tests-integerp-f) +;; (native-compile #'comp-tests-numberp-f) + +;; (should (eq (comp-tests-integerp-f 1) t)) +;; (should (eq (comp-tests-integerp-f '(1)) nil)) +;; (should (eq (comp-tests-integerp-f 3.5) nil)) +;; (should (eq (comp-tests-integerp-f (1+ most-negative-fixnum)) t)) + +;; (should (eq (comp-tests-numberp-f 1) t)) +;; (should (eq (comp-tests-numberp-f 'a) nil)) +;; (should (eq (comp-tests-numberp-f 3.5) t))) + +;; (ert-deftest comp-tests-stack () +;; "Test some stack operation." +;; (defun comp-tests-discardn-f (x) +;; ;; BdiscardN +;; (1+ (let ((a 1) +;; (_b) +;; (_c)) +;; a))) +;; (defun comp-tests-insertn-f (a b c d) +;; ;; Binsert +;; (insert a b c d)) + +;; (native-compile #'comp-tests-discardn-f) +;; (native-compile #'comp-tests-insertn-f) + +;; (should (= (comp-tests-discardn-f 10) 2)) + +;; (should (string= (with-temp-buffer +;; (comp-tests-insertn-f "a" "b" "c" "d") +;; (buffer-string)) +;; "abcd"))) + +;; (ert-deftest comp-tests-non-locals () +;; "Test non locals." +;; (defun comp-tests-err-arith-f () +;; (/ 1 0)) +;; (defun comp-tests-err-foo-f () +;; (error "foo")) + +;; (defun comp-tests-condition-case-0-f () +;; ;; Bpushhandler Bpophandler +;; (condition-case +;; err +;; (comp-tests-err-arith-f) +;; (arith-error (concat "arith-error " +;; (error-message-string err) +;; " catched")) +;; (error (concat "error " +;; (error-message-string err) +;; " catched")))) + +;; (defun comp-tests-condition-case-1-f () +;; ;; Bpushhandler Bpophandler +;; (condition-case +;; err +;; (comp-tests-err-foo-f) +;; (arith-error (concat "arith-error " +;; (error-message-string err) +;; " catched")) +;; (error (concat "error " +;; (error-message-string err) +;; " catched")))) + +;; (defun comp-tests-catch-f (f) +;; (catch 'foo +;; (funcall f))) + +;; (defun comp-tests-throw-f (x) +;; (throw 'foo x)) + +;; (native-compile #'comp-tests-condition-case-0-f) +;; (native-compile #'comp-tests-condition-case-1-f) +;; (native-compile #'comp-tests-catch-f) +;; (native-compile #'comp-tests-throw-f) + +;; (should (string= (comp-tests-condition-case-0-f) +;; "arith-error Arithmetic error catched")) +;; (should (string= (comp-tests-condition-case-1-f) +;; "error foo catched")) +;; (should (= (comp-tests-catch-f (lambda () (throw 'foo 3))) 3)) +;; (should (= (catch 'foo +;; (comp-tests-throw-f 3))))) + +;; (ert-deftest comp-tests-gc () +;; "Try to do some longer computation to let the gc kick in." +;; (dotimes (_ 100000) +;; (comp-tests-cons-cdr-f 3)) + +;; (should (= (comp-tests-cons-cdr-f 3) 3))) ;;; comp-tests.el ends here commit 25908f52e16e4a5de86f85945a89fa50c714188d Author: Andrea Corallo Date: Wed Jul 10 00:39:42 2019 +0200 parameter passing works again diff --git a/src/comp.c b/src/comp.c index bb056620d0..a52aa242c0 100644 --- a/src/comp.c +++ b/src/comp.c @@ -139,9 +139,6 @@ static comp_t comp; FILE *logfile = NULL; -void emacs_native_compile (const char *lisp_f_name, const char *c_f_name, - Lisp_Object func, int opt_level, bool dump_asm); - static char * ATTRIBUTE_FORMAT_PRINTF (1, 2) format_string (const char *format, ...) { @@ -985,7 +982,7 @@ emit_limple_inst (Lisp_Object inst) gcc_jit_block_end_with_jump (comp.block, NULL, target); comp.block = target; } - else if (EQ (op, Qeqcall)) + else if (EQ (op, Q_call_ass)) { EMACS_UINT slot_n = XFIXNUM (FUNCALL1 (comp-mvar-slot, arg0)); Lisp_Object arg1 = THIRD (inst); @@ -1000,7 +997,20 @@ emit_limple_inst (Lisp_Object inst) comp.frame[slot_n], res); } - else if (EQ (op, Qeqconst)) + else if (EQ (op, Q_par_ass)) + { + /* Ex: (=par #s(comp-mvar 2 0 nil nil nil) 0). */ + EMACS_UINT slot_n = XFIXNUM (FUNCALL1 (comp-mvar-slot, arg0)); + EMACS_UINT param_n = XFIXNUM (THIRD (inst)); + gcc_jit_rvalue *param = + gcc_jit_param_as_rvalue (gcc_jit_function_get_param (comp.func, + param_n)); + gcc_jit_block_add_assignment (comp.block, + NULL, + comp.frame[slot_n], + param); + } + else if (EQ (op, Q_const_ass)) { } else if (EQ (op, Qreturn)) @@ -1987,10 +1997,11 @@ syms_of_comp (void) /* Limple instruction set. */ DEFSYM (Qblock, "block"); DEFSYM (Qjump, "jump"); - DEFSYM (Qeqcall, "=call"); DEFSYM (Qcall, "call"); DEFSYM (Qncall, "ncall"); - DEFSYM (Qeqconst, "=const"); + DEFSYM (Q_par_ass, "=par"); + DEFSYM (Q_call_ass, "=call"); + DEFSYM (Q_const_ass, "=const"); DEFSYM (Qreturn, "return"); defsubr (&Scomp_init_ctxt); commit 30ba6d253246c0b0f91fa3e6b30f1694f446e88a Author: Andrea Corallo Date: Wed Jul 10 02:36:49 2019 +0200 rename entry block diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index e3cb868438..fe5a0694ee 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -291,7 +291,7 @@ VAL is known at compile time." :frame (comp-limple-frame-new-frame frame-size))) (comp-limple ())) ;; Prologue - (comp-push-block 'prologue) + (comp-push-block 'entry) (cl-loop for i below (comp-args-mandatory (comp-func-args func)) do (progn (cl-incf (comp-sp)) commit 24f80e510f51e0155fe3701c86d553e2f77d4093 Author: Andrea Corallo Date: Wed Jul 10 02:36:28 2019 +0200 rework hashtable usage diff --git a/src/comp.c b/src/comp.c index 0670bf24bd..bb056620d0 100644 --- a/src/comp.c +++ b/src/comp.c @@ -205,12 +205,9 @@ retrive_block (Lisp_Object symbol) { char *block_name = (char *) SDATA (SYMBOL_NAME (symbol)); Lisp_Object key = make_string (block_name, strlen (block_name)); - EMACS_UINT hash = 0; - struct Lisp_Hash_Table *ht = XHASH_TABLE (comp.func_blocks); - ptrdiff_t i = hash_lookup (ht, key, &hash); - if (i == -1) + Lisp_Object value = Fgethash (key, comp.func_blocks, Qnil); + if (NILP (value)) error ("LIMPLE basic block inconsistency"); - Lisp_Object value = HASH_VALUE (ht, hash_lookup (ht, key, &hash)); return (gcc_jit_block *) XFIXNUMPTR (value); } @@ -221,12 +218,9 @@ declare_block (char *block_name) gcc_jit_block *block = gcc_jit_function_new_block (comp.func, block_name); Lisp_Object key = make_string (block_name, strlen (block_name)); Lisp_Object value = make_pointer_integer (XPL (block)); - EMACS_UINT hash = 0; - struct Lisp_Hash_Table *ht = XHASH_TABLE (comp.func_blocks); - ptrdiff_t i = hash_lookup (ht, key, &hash); - if (i != -1) + if (!NILP (Fgethash (key, comp.func_blocks, Qnil))) error ("LIMPLE basic block inconsistency"); - hash_put (ht, key, value, hash); + Fputhash (key, value, comp.func_blocks); } INLINE static void @@ -293,12 +287,10 @@ emit_func_declare (const char *f_name, gcc_jit_type *ret_type, { Lisp_Object key = make_string (f_name, strlen (f_name)); Lisp_Object value = make_pointer_integer (XPL (func)); - EMACS_UINT hash = 0; - struct Lisp_Hash_Table *ht = XHASH_TABLE (comp.func_hash); - ptrdiff_t i = hash_lookup (ht, key, &hash); /* Don't want to declare the same function two times. */ - eassert (i == -1); - hash_put (ht, key, value, hash); + if (!NILP (Fgethash (key, comp.func_hash, Qnil))) + eassert (false); + Fputhash (key, value, comp.func_hash); } return func; @@ -309,19 +301,15 @@ emit_call (const char *f_name, gcc_jit_type *ret_type, unsigned nargs, gcc_jit_rvalue **args) { Lisp_Object key = make_string (f_name, strlen (f_name)); - EMACS_UINT hash = 0; - struct Lisp_Hash_Table *ht = XHASH_TABLE (comp.func_hash); - ptrdiff_t i = hash_lookup (ht, key, &hash); + Lisp_Object value = Fgethash (key, comp.func_hash, Qnil); - if (i == -1) + if (NILP (value)) { emit_func_declare (f_name, ret_type, nargs, args, GCC_JIT_FUNCTION_IMPORTED, true); - i = hash_lookup (ht, key, &hash); - eassert (i != -1); + value = Fgethash (key, comp.func_hash, Qnil); + eassert (!NILP (value)); } - - Lisp_Object value = HASH_VALUE (ht, hash_lookup (ht, key, &hash)); gcc_jit_function *func = (gcc_jit_function *) XFIXNUMPTR (value); return gcc_jit_context_new_call(comp.ctxt, commit 99ec0b493a48fefc69b337cd0d30290dfa1cf858 Author: Andrea Corallo Date: Tue Jul 9 23:54:07 2019 +0200 proper return in place diff --git a/src/comp.c b/src/comp.c index 668e7a67dc..0670bf24bd 100644 --- a/src/comp.c +++ b/src/comp.c @@ -964,6 +964,21 @@ emit_PURE_P (gcc_jit_rvalue *ptr) /* return emit_call (f_name, comp.lisp_obj_type, 2, args); */ /* } */ +/* Retrive an r-value from a meta variable. + In case this is a constant that was propagated return it otherwise load it + from the frame. */ + +static gcc_jit_rvalue * +retrive_mvar_val (Lisp_Object mvar) +{ + if (NILP (FUNCALL1 (comp-mvar-const-vld, mvar))) + return + gcc_jit_lvalue_as_rvalue( + comp.frame[XFIXNUM (FUNCALL1 (comp-mvar-slot, mvar))]); + else + return emit_lisp_obj_from_ptr (FUNCALL1 (comp-mvar-constant, mvar)); +} + static void emit_limple_inst (Lisp_Object inst) { @@ -1002,12 +1017,9 @@ emit_limple_inst (Lisp_Object inst) } else if (EQ (op, Qreturn)) { - gcc_jit_rvalue *ret_val = - emit_lisp_obj_from_ptr ( - FUNCALL1 (comp-mvar-constant, arg0)); gcc_jit_block_end_with_return (comp.block, NULL, - ret_val); + retrive_mvar_val (arg0)); } } @@ -1961,7 +1973,8 @@ DEFUN ("comp-compile-and-load-ctxt", Fcomp_compile_and_load_ctxt, union Aligned_Lisp_Subr *x = xmalloc (sizeof (union Aligned_Lisp_Subr)); Lisp_Object func = XCAR (comp.funcs); Lisp_Object args = FUNCALL1 (comp-func-args, func); - char *symbol_name = (char *) SDATA (FUNCALL1 (symbol-name, func)); + char *symbol_name = + (char *) SDATA (SYMBOL_NAME (FUNCALL1 (comp-func-symbol-name, func))); char *c_name = (char *) SDATA (FUNCALL1 (comp-func-c-func-name, func)); x->s.header.size = PVEC_SUBR << PSEUDOVECTOR_AREA_BITS; commit 40ffcb131513386b24cf16ecc566f01a3666a895 Author: Andrea Corallo Date: Tue Jul 9 23:32:50 2019 +0200 simple call support diff --git a/src/comp.c b/src/comp.c index c9207e1869..668e7a67dc 100644 --- a/src/comp.c +++ b/src/comp.c @@ -37,6 +37,13 @@ along with GNU Emacs. If not, see . */ #define STR(s) #s +#define FIRST(x) \ + XCAR(x) +#define SECOND(x) \ + XCAR (XCDR (x)) +#define THIRD(x) \ + XCAR (XCDR (XCDR (x))) + #define FUNCALL1(fun, arg) \ CALLN (Ffuncall, intern (STR(fun)), arg) @@ -109,6 +116,7 @@ typedef struct { gcc_jit_field *cast_union_as_lisp_obj_ptr; gcc_jit_function *func; /* Current function being compiled. */ gcc_jit_block *block; /* Current basic block being compiled. */ + gcc_jit_lvalue **frame; /* Frame for the current function. */ gcc_jit_rvalue *most_positive_fixnum; gcc_jit_rvalue *most_negative_fixnum; gcc_jit_rvalue *one; @@ -960,7 +968,7 @@ static void emit_limple_inst (Lisp_Object inst) { Lisp_Object op = XCAR (inst); - Lisp_Object arg0 = XCAR (XCDR (inst)); + Lisp_Object arg0 = SECOND (inst); if (EQ (op, Qblock)) { @@ -976,6 +984,18 @@ emit_limple_inst (Lisp_Object inst) } else if (EQ (op, Qeqcall)) { + EMACS_UINT slot_n = XFIXNUM (FUNCALL1 (comp-mvar-slot, arg0)); + Lisp_Object arg1 = THIRD (inst); + eassert (FIRST (arg1) == Qcall); + char *calle = (char *) SDATA (SYMBOL_NAME (SECOND (arg1))); + gcc_jit_rvalue *args[] = + { emit_lisp_obj_from_ptr (THIRD (arg1)) }; + gcc_jit_rvalue *res = emit_call (calle, comp.lisp_obj_type, 1, args); + + gcc_jit_block_add_assignment (comp.block, + NULL, + comp.frame[slot_n], + res); } else if (EQ (op, Qeqconst)) { @@ -1886,6 +1906,7 @@ DEFUN ("comp-add-func-to-ctxt", Fcomp_add_func_to_ctxt, Scomp_add_func_to_ctxt, gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.int_type, i)); + comp.frame = frame; comp.func_blocks = CALLN (Fmake_hash_table, QCtest, Qequal, QCweakness, Qt); @@ -1966,6 +1987,8 @@ syms_of_comp (void) DEFSYM (Qblock, "block"); DEFSYM (Qjump, "jump"); DEFSYM (Qeqcall, "=call"); + DEFSYM (Qcall, "call"); + DEFSYM (Qncall, "ncall"); DEFSYM (Qeqconst, "=const"); DEFSYM (Qreturn, "return"); commit 1b9e05b430d0cc09480e53fb1eaa5c724f99b078 Author: Andrea Corallo Date: Tue Jul 9 22:50:52 2019 +0200 fix function name diff --git a/src/comp.c b/src/comp.c index 7c97560d2e..c9207e1869 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1940,6 +1940,7 @@ DEFUN ("comp-compile-and-load-ctxt", Fcomp_compile_and_load_ctxt, union Aligned_Lisp_Subr *x = xmalloc (sizeof (union Aligned_Lisp_Subr)); Lisp_Object func = XCAR (comp.funcs); Lisp_Object args = FUNCALL1 (comp-func-args, func); + char *symbol_name = (char *) SDATA (FUNCALL1 (symbol-name, func)); char *c_name = (char *) SDATA (FUNCALL1 (comp-func-c-func-name, func)); x->s.header.size = PVEC_SUBR << PSEUDOVECTOR_AREA_BITS; @@ -1947,7 +1948,7 @@ DEFUN ("comp-compile-and-load-ctxt", Fcomp_compile_and_load_ctxt, eassert (x->s.function.a0); x->s.min_args = XFIXNUM (FUNCALL1 (comp-args-min, args)); x->s.max_args = XFIXNUM (FUNCALL1 (comp-args-min, args)); - x->s.symbol_name = "foo"; + x->s.symbol_name = symbol_name; defsubr(x); comp.funcs = XCDR (comp.funcs); commit c1a738bd98f7eaaf4dcc87b0769dad2821178ab8 Author: Andrea Corallo Date: Tue Jul 9 22:28:29 2019 +0200 update tests diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 93e3bf17b3..e3cb868438 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -79,7 +79,7 @@ To be used when ncall-conv is nil.") (cl-defstruct (comp-mvar (:copier nil) (:constructor make--comp-mvar)) "A meta-variable being a slot in the meta-stack." - (n nil :type number + (id nil :type number :documentation "SSA number") (slot nil :type fixnum :documentation "Slot position") @@ -139,8 +139,11 @@ To be used when ncall-conv is nil.") (byte-compile (comp-func-symbol-name func))) (when comp-debug (cl-prettyprint byte-compile-lap-output)) - (setf (comp-func-args func) - (comp-decrypt-lambda-list (aref (comp-func-byte-func func) 0))) + (let ((lambda-list (aref (comp-func-byte-func func) 0))) + (if (fixnump lambda-list) + (setf (comp-func-args func) + (comp-decrypt-lambda-list (aref (comp-func-byte-func func) 0))) + (error "Can't native compile a non lexical scoped function"))) (setf (comp-func-ir func) byte-compile-lap-output) (setf (comp-func-frame-size func) (aref (comp-func-byte-func func) 3)) func) @@ -163,7 +166,7 @@ To be used when ncall-conv is nil.") (defvar comp-func) (cl-defun make-comp-mvar (&key slot const-vld constant type) - (make--comp-mvar :n (cl-incf (comp-func-limple-cnt comp-func)) + (make--comp-mvar :id (cl-incf (comp-func-limple-cnt comp-func)) :slot slot :const-vld const-vld :constant constant :type type)) @@ -207,11 +210,10 @@ To be used when ncall-conv is nil.") "Push VAL into frame. VAL is known at compile time." (cl-incf (comp-sp)) - (let ((const (make-comp-mvar :slot (comp-sp) + (setf (comp-slot) (make-comp-mvar :slot (comp-sp) :const-vld t - :constant val))) - (setf (comp-slot) const) - (push (list '=const (comp-slot) const) comp-limple))) + :constant val)) + (push (list '=const (comp-slot) val) comp-limple)) (defun comp-push-block (bblock) "Push basic block BBLOCK." @@ -307,8 +309,6 @@ VAL is known at compile time." (defun native-compile (fun) "FUN is the function definition to be compiled into native code." - (unless lexical-binding - (error "Can't native compile a non lexical scoped function")) (if-let ((f (symbol-function fun))) (progn (when (byte-code-function-p f) diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index c6ee5b7685..8d3a0f507d 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -26,6 +26,7 @@ ;;; Code: (require 'ert) +(require 'comp) (setq garbage-collection-messages t) @@ -103,10 +104,6 @@ (defun comp-tests-varset-f () (setq comp-tests-var1 55)) (comp-test-compile #'comp-tests-varset-f) -((byte-constant 55 . 1) - (byte-dup . 0) - (byte-varset comp-tests-var1 . 0) - (byte-return . 0)) (comp-tests-varset-f) commit 0a227b6db46dcd5c4af0b6266d4f642b0c6157b5 Author: Andrea Corallo Date: Tue Jul 9 18:09:47 2019 +0200 wipe out propagation info every new basic block diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index d780e9363c..93e3bf17b3 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -98,6 +98,13 @@ To be used when ncall-conv is nil.") (frame nil :type 'vector :documentation "Meta-stack used to flat LAP")) +(defun comp-limple-frame-new-frame (size) + "Return a clean frame of meta variables of size SIZE." + (let ((v (make-vector size nil))) + (cl-loop for i below size + do (aset v i (make-comp-mvar :slot i))) + v)) + (defun comp-c-func-name (symbol-function) "Given SYMBOL-FUNCTION return a name suitable for the native code." ;; Unfortunatelly not all symbol names are valid as C function names... @@ -206,9 +213,13 @@ VAL is known at compile time." (setf (comp-slot) const) (push (list '=const (comp-slot) const) comp-limple))) -(defun comp-push_block (bblock) +(defun comp-push-block (bblock) "Push basic block BBLOCK." (push bblock (comp-func-blocks comp-func)) + ;; Every new block we are forced to wipe out all the frame. + ;; This will be superseded by proper flow analysis. + (setf (comp-limple-frame-frame comp-frame) + (comp-limple-frame-new-frame (comp-func-frame-size comp-func))) (push `(block ,bblock) comp-limple)) (defun comp-pop (n) @@ -275,20 +286,17 @@ VAL is known at compile time." (comp-func func) (comp-frame (make-comp-limple-frame :sp -1 - :frame (let ((v (make-vector frame-size nil))) - (cl-loop for i below frame-size - do (aset v i (make-comp-mvar :slot i))) - v))) + :frame (comp-limple-frame-new-frame frame-size))) (comp-limple ())) ;; Prologue - (comp-push_block 'prologue) + (comp-push-block 'prologue) (cl-loop for i below (comp-args-mandatory (comp-func-args func)) do (progn (cl-incf (comp-sp)) (push `(=par ,(comp-slot) ,i) comp-limple))) (push '(jump body) comp-limple) ;; Body - (comp-push_block 'body) + (comp-push-block 'body) (mapc #'comp-limplify-lap-inst (comp-func-ir func)) (setf (comp-func-ir func) (reverse comp-limple)) ;; Prologue block must be first commit e46c54e7387523e22f2ce371fd991d1edb4b09cb Author: Andrea Corallo Date: Tue Jul 9 14:46:52 2019 +0200 introduce FUNCALL1 macro diff --git a/src/comp.c b/src/comp.c index e524e28b14..7c97560d2e 100644 --- a/src/comp.c +++ b/src/comp.c @@ -37,6 +37,9 @@ along with GNU Emacs. If not, see . */ #define STR(s) #s +#define FUNCALL1(fun, arg) \ + CALLN (Ffuncall, intern (STR(fun)), arg) + #define DECL_BLOCK(name, func) \ gcc_jit_block *(name) = \ gcc_jit_function_new_block ((func), STR(name)) @@ -981,7 +984,7 @@ emit_limple_inst (Lisp_Object inst) { gcc_jit_rvalue *ret_val = emit_lisp_obj_from_ptr ( - CALLN (Ffuncall, intern ("comp-mvar-constant"), arg0)); + FUNCALL1 (comp-mvar-constant, arg0)); gcc_jit_block_end_with_return (comp.block, NULL, ret_val); @@ -1845,17 +1848,12 @@ DEFUN ("comp-add-func-to-ctxt", Fcomp_add_func_to_ctxt, Scomp_add_func_to_ctxt, doc: /* Add limple FUNC to the current compilation context. */) (Lisp_Object func) { - char *c_name = - (char *) SDATA (CALLN (Ffuncall, intern ("comp-func-c-func-name"), func)); - Lisp_Object args = (CALLN (Ffuncall, intern ("comp-func-args"), func)); - EMACS_INT frame_size = - XFIXNUM (CALLN (Ffuncall, intern ("comp-func-frame-size"), func)); - EMACS_INT min_args = - XFIXNUM (CALLN (Ffuncall, intern ("comp-args-min"), args)); - EMACS_INT max_args = - XFIXNUM (CALLN (Ffuncall, intern ("comp-args-max"), args)); - bool ncall = - !NILP (CALLN (Ffuncall, intern ("comp-args-ncall-conv"), args)); + char *c_name = (char *) SDATA (FUNCALL1 (comp-func-c-func-name, func)); + Lisp_Object args = FUNCALL1 (comp-func-args, func); + EMACS_INT frame_size = XFIXNUM (FUNCALL1 (comp-func-frame-size, func)); + EMACS_INT min_args = XFIXNUM (FUNCALL1 (comp-args-min, args)); + EMACS_INT max_args = XFIXNUM (FUNCALL1 (comp-args-max, args)); + bool ncall = !NILP (FUNCALL1 (comp-args-ncall-conv, args)); if (!ncall) { @@ -1892,7 +1890,7 @@ DEFUN ("comp-add-func-to-ctxt", Fcomp_add_func_to_ctxt, Scomp_add_func_to_ctxt, comp.func_blocks = CALLN (Fmake_hash_table, QCtest, Qequal, QCweakness, Qt); /* Pre declare all basic blocks. */ - Lisp_Object blocks = (CALLN (Ffuncall, intern ("comp-func-blocks"), func)); + Lisp_Object blocks = FUNCALL1 (comp-func-blocks, func); while (CONSP (blocks)) { char *block_name = (char *) SDATA (SYMBOL_NAME (XCAR (blocks))); @@ -1900,7 +1898,7 @@ DEFUN ("comp-add-func-to-ctxt", Fcomp_add_func_to_ctxt, Scomp_add_func_to_ctxt, blocks = XCDR (blocks); } - Lisp_Object limple = (CALLN (Ffuncall, intern ("comp-func-ir"), func)); + Lisp_Object limple = FUNCALL1 (comp-func-ir, func); while (CONSP (limple)) { @@ -1941,17 +1939,14 @@ DEFUN ("comp-compile-and-load-ctxt", Fcomp_compile_and_load_ctxt, { union Aligned_Lisp_Subr *x = xmalloc (sizeof (union Aligned_Lisp_Subr)); Lisp_Object func = XCAR (comp.funcs); - Lisp_Object args = (CALLN (Ffuncall, intern ("comp-func-args"), func)); - char *c_name = - (char *) SDATA (CALLN (Ffuncall, - intern ("comp-func-c-func-name"), - func)); + Lisp_Object args = FUNCALL1 (comp-func-args, func); + char *c_name = (char *) SDATA (FUNCALL1 (comp-func-c-func-name, func)); x->s.header.size = PVEC_SUBR << PSEUDOVECTOR_AREA_BITS; x->s.function.a0 = gcc_jit_result_get_code(gcc_res, c_name); eassert (x->s.function.a0); - x->s.min_args = XFIXNUM (CALLN (Ffuncall, intern ("comp-args-min"), args)); - x->s.max_args = XFIXNUM (CALLN (Ffuncall, intern ("comp-args-min"), args)); + x->s.min_args = XFIXNUM (FUNCALL1 (comp-args-min, args)); + x->s.max_args = XFIXNUM (FUNCALL1 (comp-args-min, args)); x->s.symbol_name = "foo"; defsubr(x); commit cd55772c8c4fea27b344633dec7ad893cf799036 Author: Andrea Corallo Date: Mon Jul 8 18:33:56 2019 +0200 first functional function diff --git a/src/comp.c b/src/comp.c index 4f6382304a..e524e28b14 100644 --- a/src/comp.c +++ b/src/comp.c @@ -121,6 +121,7 @@ typedef struct { gcc_jit_function *check_impure; Lisp_Object func_blocks; /* blk_name -> gcc_block. */ Lisp_Object func_hash; /* f_name -> gcc_func. */ + Lisp_Object funcs; /* List of functions defined. */ } comp_t; static comp_t comp; @@ -1686,6 +1687,7 @@ DEFUN ("comp-init-ctxt", Fcomp_init_ctxt, Scomp_init_ctxt, return Qnil; } comp.ctxt = gcc_jit_context_acquire(); + comp.funcs = Qnil; if (COMP_DEBUG) { @@ -1907,6 +1909,8 @@ DEFUN ("comp-add-func-to-ctxt", Fcomp_add_func_to_ctxt, Scomp_add_func_to_ctxt, limple = XCDR (limple); } + comp.funcs = Fcons (func, comp.funcs); + return Qt; } @@ -1933,15 +1937,26 @@ DEFUN ("comp-compile-and-load-ctxt", Fcomp_compile_and_load_ctxt, GCC_JIT_OUTPUT_KIND_ASSEMBLER, "gcc-ctxt-dump.s"); - /* FIXME: must iterate all function names. */ - union Aligned_Lisp_Subr *x = xmalloc (sizeof (union Aligned_Lisp_Subr)); - x->s.header.size = PVEC_SUBR << PSEUDOVECTOR_AREA_BITS; - x->s.function.a0 = gcc_jit_result_get_code(gcc_res, "F666f6f_foo"); - eassert (x->s.function.a0); - x->s.min_args = 0; - x->s.max_args = 0; - x->s.symbol_name = "foo"; - defsubr(x); + while (CONSP (comp.funcs)) + { + union Aligned_Lisp_Subr *x = xmalloc (sizeof (union Aligned_Lisp_Subr)); + Lisp_Object func = XCAR (comp.funcs); + Lisp_Object args = (CALLN (Ffuncall, intern ("comp-func-args"), func)); + char *c_name = + (char *) SDATA (CALLN (Ffuncall, + intern ("comp-func-c-func-name"), + func)); + + x->s.header.size = PVEC_SUBR << PSEUDOVECTOR_AREA_BITS; + x->s.function.a0 = gcc_jit_result_get_code(gcc_res, c_name); + eassert (x->s.function.a0); + x->s.min_args = XFIXNUM (CALLN (Ffuncall, intern ("comp-args-min"), args)); + x->s.max_args = XFIXNUM (CALLN (Ffuncall, intern ("comp-args-min"), args)); + x->s.symbol_name = "foo"; + defsubr(x); + + comp.funcs = XCDR (comp.funcs); + } unblock_atimers (&oldset); commit 3f98a32b7e15fd32da15b5be6fb4ef77a1e43a43 Author: Andrea Corallo Date: Mon Jul 8 17:44:19 2019 +0200 basic blocks into C diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 17de79bc47..d780e9363c 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -291,6 +291,8 @@ VAL is known at compile time." (comp-push_block 'body) (mapc #'comp-limplify-lap-inst (comp-func-ir func)) (setf (comp-func-ir func) (reverse comp-limple)) + ;; Prologue block must be first + (setf (comp-func-blocks func) (reverse (comp-func-blocks func))) (when comp-debug (cl-prettyprint (comp-func-ir func))) func)) diff --git a/src/comp.c b/src/comp.c index ca741fc9f1..4f6382304a 100644 --- a/src/comp.c +++ b/src/comp.c @@ -119,7 +119,8 @@ typedef struct { gcc_jit_function *setcdr; gcc_jit_function *check_type; gcc_jit_function *check_impure; - Lisp_Object func_hash; /* f_name -> gcc_func */ + Lisp_Object func_blocks; /* blk_name -> gcc_block. */ + Lisp_Object func_hash; /* f_name -> gcc_func. */ } comp_t; static comp_t comp; @@ -187,6 +188,35 @@ type_to_cast_field (gcc_jit_type *type) return field; } +static gcc_jit_block * +retrive_block (Lisp_Object symbol) +{ + char *block_name = (char *) SDATA (SYMBOL_NAME (symbol)); + Lisp_Object key = make_string (block_name, strlen (block_name)); + EMACS_UINT hash = 0; + struct Lisp_Hash_Table *ht = XHASH_TABLE (comp.func_blocks); + ptrdiff_t i = hash_lookup (ht, key, &hash); + if (i == -1) + error ("LIMPLE basic block inconsistency"); + Lisp_Object value = HASH_VALUE (ht, hash_lookup (ht, key, &hash)); + + return (gcc_jit_block *) XFIXNUMPTR (value); +} + +static void +declare_block (char *block_name) +{ + gcc_jit_block *block = gcc_jit_function_new_block (comp.func, block_name); + Lisp_Object key = make_string (block_name, strlen (block_name)); + Lisp_Object value = make_pointer_integer (XPL (block)); + EMACS_UINT hash = 0; + struct Lisp_Hash_Table *ht = XHASH_TABLE (comp.func_blocks); + ptrdiff_t i = hash_lookup (ht, key, &hash); + if (i != -1) + error ("LIMPLE basic block inconsistency"); + hash_put (ht, key, value, hash); +} + INLINE static void emit_comment (const char *str) { @@ -249,14 +279,12 @@ emit_func_declare (const char *f_name, gcc_jit_type *ret_type, if (reusable) { - Lisp_Object value; Lisp_Object key = make_string (f_name, strlen (f_name)); - value = make_pointer_integer (XPL (func)); - + Lisp_Object value = make_pointer_integer (XPL (func)); EMACS_UINT hash = 0; struct Lisp_Hash_Table *ht = XHASH_TABLE (comp.func_hash); ptrdiff_t i = hash_lookup (ht, key, &hash); - /* Don't want to declare the same function two times */ + /* Don't want to declare the same function two times. */ eassert (i == -1); hash_put (ht, key, value, hash); } @@ -932,12 +960,15 @@ emit_limple_inst (Lisp_Object inst) if (EQ (op, Qblock)) { - char *block_name = SDATA (SYMBOL_NAME (arg0)); - comp.block = gcc_jit_function_new_block (comp.func, block_name); + /* Search for the already defined block and make it current. */ + comp.block = retrive_block (arg0); } else if (EQ (op, Qjump)) { - + /* Unconditional branch. */ + gcc_jit_block *target = retrive_block (arg0); + gcc_jit_block_end_with_jump (comp.block, NULL, target); + comp.block = target; } else if (EQ (op, Qeqcall)) { @@ -947,6 +978,12 @@ emit_limple_inst (Lisp_Object inst) } else if (EQ (op, Qreturn)) { + gcc_jit_rvalue *ret_val = + emit_lisp_obj_from_ptr ( + CALLN (Ffuncall, intern ("comp-mvar-constant"), arg0)); + gcc_jit_block_end_with_return (comp.block, + NULL, + ret_val); } } @@ -1829,7 +1866,7 @@ DEFUN ("comp-add-func-to-ctxt", Fcomp_add_func_to_ctxt, Scomp_add_func_to_ctxt, error ("Not supported for now"); } - gcc_jit_lvalue *meta_frame = + gcc_jit_lvalue *frame_array = gcc_jit_function_new_local ( comp.func, NULL, @@ -1845,11 +1882,22 @@ DEFUN ("comp-add-func-to-ctxt", Fcomp_add_func_to_ctxt, Scomp_add_func_to_ctxt, gcc_jit_context_new_array_access ( comp.ctxt, NULL, - gcc_jit_lvalue_as_rvalue (meta_frame), + gcc_jit_lvalue_as_rvalue (frame_array), gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.int_type, i)); + comp.func_blocks = CALLN (Fmake_hash_table, QCtest, Qequal, QCweakness, Qt); + + /* Pre declare all basic blocks. */ + Lisp_Object blocks = (CALLN (Ffuncall, intern ("comp-func-blocks"), func)); + while (CONSP (blocks)) + { + char *block_name = (char *) SDATA (SYMBOL_NAME (XCAR (blocks))); + declare_block (block_name); + blocks = XCDR (blocks); + } + Lisp_Object limple = (CALLN (Ffuncall, intern ("comp-func-ir"), func)); while (CONSP (limple)) @@ -1857,7 +1905,7 @@ DEFUN ("comp-add-func-to-ctxt", Fcomp_add_func_to_ctxt, Scomp_add_func_to_ctxt, Lisp_Object inst = XCAR (limple); emit_limple_inst (inst); limple = XCDR (limple); - }; + } return Qt; } @@ -1876,6 +1924,25 @@ DEFUN ("comp-compile-and-load-ctxt", Fcomp_compile_and_load_ctxt, sigset_t oldset; block_atimers (&oldset); + if (COMP_DEBUG) + gcc_jit_context_dump_to_file (comp.ctxt, "gcc-ctxt-dump.c", 1); + gcc_jit_result *gcc_res = gcc_jit_context_compile(comp.ctxt); + + if (!NILP (disassemble)) + gcc_jit_context_compile_to_file (comp.ctxt, + GCC_JIT_OUTPUT_KIND_ASSEMBLER, + "gcc-ctxt-dump.s"); + + /* FIXME: must iterate all function names. */ + union Aligned_Lisp_Subr *x = xmalloc (sizeof (union Aligned_Lisp_Subr)); + x->s.header.size = PVEC_SUBR << PSEUDOVECTOR_AREA_BITS; + x->s.function.a0 = gcc_jit_result_get_code(gcc_res, "F666f6f_foo"); + eassert (x->s.function.a0); + x->s.min_args = 0; + x->s.max_args = 0; + x->s.symbol_name = "foo"; + defsubr(x); + unblock_atimers (&oldset); return Qt; @@ -1897,6 +1964,7 @@ syms_of_comp (void) defsubr (&Scomp_compile_and_load_ctxt); comp.func_hash = Qnil; staticpro (&comp.func_hash); + staticpro (&comp.func_blocks); DEFVAR_INT ("comp-speed", comp_speed, doc: /* From 0 to 3. */); commit a59ef0747f855fb30d66ff98c739965fafdfe0c7 Author: Andrea Corallo Date: Mon Jul 8 17:04:33 2019 +0200 block list in limple diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 963c22dc59..17de79bc47 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -72,6 +72,8 @@ To be used when ncall-conv is nil.") :documentation "Current intermediate rappresentation") (args nil :type 'comp-args) (frame-size nil :type 'number) + (blocks () :type list + :documentation "List of basic block") (limple-cnt -1 :type 'number :documentation "Counter to create ssa limple vars")) @@ -198,10 +200,16 @@ To be used when ncall-conv is nil.") "Push VAL into frame. VAL is known at compile time." (cl-incf (comp-sp)) - (setf (comp-slot) (make-comp-mvar :slot (comp-sp) + (let ((const (make-comp-mvar :slot (comp-sp) :const-vld t - :constant val)) - (push (list '=const (comp-slot) val) comp-limple)) + :constant val))) + (setf (comp-slot) const) + (push (list '=const (comp-slot) const) comp-limple))) + +(defun comp-push_block (bblock) + "Push basic block BBLOCK." + (push bblock (comp-func-blocks comp-func)) + (push `(block ,bblock) comp-limple)) (defun comp-pop (n) "Pop N elements from the meta-stack." @@ -262,7 +270,7 @@ VAL is known at compile time." (_ (error "Unexpected LAP op %s" (symbol-name op)))))) (defun comp-limplify (func) - "Given FUNC and return LIMPLE." + "Given FUNC and return compute its LIMPLE ir." (let* ((frame-size (comp-func-frame-size func)) (comp-func func) (comp-frame (make-comp-limple-frame @@ -273,12 +281,14 @@ VAL is known at compile time." v))) (comp-limple ())) ;; Prologue - (push '(BLOCK prologue) comp-limple) + (comp-push_block 'prologue) (cl-loop for i below (comp-args-mandatory (comp-func-args func)) do (progn (cl-incf (comp-sp)) (push `(=par ,(comp-slot) ,i) comp-limple))) - (push '(BLOCK body) comp-limple) + (push '(jump body) comp-limple) + ;; Body + (comp-push_block 'body) (mapc #'comp-limplify-lap-inst (comp-func-ir func)) (setf (comp-func-ir func) (reverse comp-limple)) (when comp-debug diff --git a/src/comp.c b/src/comp.c index 6f5863b7f7..ca741fc9f1 100644 --- a/src/comp.c +++ b/src/comp.c @@ -935,6 +935,10 @@ emit_limple_inst (Lisp_Object inst) char *block_name = SDATA (SYMBOL_NAME (arg0)); comp.block = gcc_jit_function_new_block (comp.func, block_name); } + else if (EQ (op, Qjump)) + { + + } else if (EQ (op, Qeqcall)) { } @@ -1881,7 +1885,8 @@ void syms_of_comp (void) { /* Limple instruction set. */ - DEFSYM (Qblock, "BLOCK"); + DEFSYM (Qblock, "block"); + DEFSYM (Qjump, "jump"); DEFSYM (Qeqcall, "=call"); DEFSYM (Qeqconst, "=const"); DEFSYM (Qreturn, "return"); commit c51b7fe2c881335c9958f75d205859d434cc6de4 Author: Andrea Corallo Date: Mon Jul 8 15:29:32 2019 +0200 start compilation C side diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 90713ec77b..963c22dc59 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -49,7 +49,14 @@ ) (cl-defstruct comp-args - mandatory nonrest rest) + (min nil :type number + :documentation "Minimum number of arguments allowed") + (max nil + :documentation "Maximum number of arguments allowed +To be used when ncall-conv is nil.") + (ncall-conv nil :type boolean + :documentation "If t the signature is: +(ptrdiff_t nargs, Lisp_Object *args)")) (cl-defstruct (comp-func (:copier nil)) "Internal rapresentation for a function." @@ -64,6 +71,7 @@ (ir nil :documentation "Current intermediate rappresentation") (args nil :type 'comp-args) + (frame-size nil :type 'number) (limple-cnt -1 :type 'number :documentation "Counter to create ssa limple vars")) @@ -105,9 +113,15 @@ (defun comp-decrypt-lambda-list (x) "Decript lambda list X." - (make-comp-args :rest (not (= (logand x 128) 0)) - :mandatory (logand x 127) - :nonrest (ash x -8))) + (let ((rest (not (= (logand x 128) 0))) + (mandatory (logand x 127)) + (nonrest (ash x -8))) + (if (and (null rest) + (< nonrest 9)) ;; SUBR_MAX_ARGS + (make-comp-args :min mandatory + :max nonrest) + (make-comp-args :min mandatory + :ncall-conv t)))) (defun comp-recuparate-lap (func) "Byte compile and recuparate LAP rapresentation for FUNC." @@ -119,6 +133,7 @@ (setf (comp-func-args func) (comp-decrypt-lambda-list (aref (comp-func-byte-func func) 0))) (setf (comp-func-ir func) byte-compile-lap-output) + (setf (comp-func-frame-size func) (aref (comp-func-byte-func func) 3)) func) (declare-function comp-init-ctxt "comp.c") @@ -242,12 +257,13 @@ VAL is known at compile time." ('byte-list4 (comp-limplify-listn 4)) ('byte-return + (push (list 'return (comp-slot)) comp-limple) `(return ,(comp-slot))) (_ (error "Unexpected LAP op %s" (symbol-name op)))))) (defun comp-limplify (func) "Given FUNC and return LIMPLE." - (let* ((frame-size (aref (comp-func-byte-func func) 3)) + (let* ((frame-size (comp-func-frame-size func)) (comp-func func) (comp-frame (make-comp-limple-frame :sp -1 @@ -284,11 +300,10 @@ VAL is known at compile time." (funcall pass func)) comp-passes) ;; Once we have the final LIMPLE we jump into C. - (when t ;(boundp #'comp-init-ctxt) - (comp-init-ctxt) - (comp-add-func-to-ctxt func) - (comp-compile-and-load-ctxt) - (comp-release-ctxt)))) + (comp-init-ctxt) + (comp-add-func-to-ctxt func) + (comp-compile-and-load-ctxt) + (comp-release-ctxt))) (error "Trying to native compile something not a function"))) (provide 'comp) diff --git a/src/comp.c b/src/comp.c index e176967da7..6f5863b7f7 100644 --- a/src/comp.c +++ b/src/comp.c @@ -35,34 +35,11 @@ along with GNU Emacs. If not, see . */ #define COMP_DEBUG 1 -#define SAFE_ALLOCA_BLOCK(ptr, func, name) \ -do { \ - (ptr) = SAFE_ALLOCA (sizeof (basic_block_t)); \ - (ptr)->gcc_bb = gcc_jit_function_new_block ((func), (name)); \ - (ptr)->terminated = false; \ - (ptr)->top = NULL; \ - } while (0) - #define STR(s) #s -#define DECL_AND_SAFE_ALLOCA_BLOCK(name, func) \ - basic_block_t *(name); \ - SAFE_ALLOCA_BLOCK ((name), (func), STR(name)) - -/* Element of the meta stack. */ -typedef struct { - gcc_jit_lvalue *gcc_lval; - enum Lisp_Type type; /* -1 if not set. */ - Lisp_Object constant; /* This is used for constant propagation. */ - bool const_set; -} stack_el_t; - -typedef struct { - gcc_jit_block *gcc_bb; - /* When non zero indicates a stack pointer restart. */ - stack_el_t *top; - bool terminated; -} basic_block_t; +#define DECL_BLOCK(name, func) \ + gcc_jit_block *(name) = \ + gcc_jit_function_new_block ((func), STR(name)) /* The compiler context */ @@ -127,7 +104,8 @@ typedef struct { gcc_jit_field *cast_union_as_lisp_cons_ptr; gcc_jit_field *cast_union_as_lisp_obj; gcc_jit_field *cast_union_as_lisp_obj_ptr; - gcc_jit_function *func; /* Current function being compiled */ + gcc_jit_function *func; /* Current function being compiled. */ + gcc_jit_block *block; /* Current basic block being compiled. */ gcc_jit_rvalue *most_positive_fixnum; gcc_jit_rvalue *most_negative_fixnum; gcc_jit_rvalue *one; @@ -141,7 +119,6 @@ typedef struct { gcc_jit_function *setcdr; gcc_jit_function *check_type; gcc_jit_function *check_impure; - basic_block_t *block; /* Current basic block */ Lisp_Object func_hash; /* f_name -> gcc_func */ } comp_t; @@ -149,13 +126,6 @@ static comp_t comp; FILE *logfile = NULL; -/* The result of one function compilation. */ - -typedef struct { - gcc_jit_result *gcc_res; - short min_args, max_args; -} comp_f_res_t; - void emacs_native_compile (const char *lisp_f_name, const char *c_f_name, Lisp_Object func, int opt_level, bool dump_asm); @@ -221,7 +191,7 @@ INLINE static void emit_comment (const char *str) { if (COMP_DEBUG) - gcc_jit_block_add_comment (comp.block->gcc_bb, + gcc_jit_block_add_comment (comp.block, NULL, str); } @@ -325,29 +295,28 @@ emit_call (const char *f_name, gcc_jit_type *ret_type, unsigned nargs, INLINE static void emit_cond_jump (gcc_jit_rvalue *test, - basic_block_t *then_target, basic_block_t *else_target) + gcc_jit_block *then_target, gcc_jit_block *else_target) { if (gcc_jit_rvalue_get_type (test) == comp.bool_type) - gcc_jit_block_end_with_conditional (comp.block->gcc_bb, + gcc_jit_block_end_with_conditional (comp.block, NULL, test, - then_target->gcc_bb, - else_target->gcc_bb); + then_target, + else_target); else /* In case test is not bool we do a logical negation to obtain a bool as result. */ gcc_jit_block_end_with_conditional ( - comp.block->gcc_bb, + comp.block, NULL, gcc_jit_context_new_unary_op (comp.ctxt, NULL, GCC_JIT_UNARY_OP_LOGICAL_NEGATE, comp.bool_type, test), - else_target->gcc_bb, - then_target->gcc_bb); + else_target, + then_target); - comp.block->terminated = true; } /* Close current basic block emitting a comparison between two rval. */ @@ -355,7 +324,7 @@ emit_cond_jump (gcc_jit_rvalue *test, /* static gcc_jit_rvalue * */ /* emit_comparison_jump (enum gcc_jit_comparison op, */ /* gcc_jit_rvalue *a, gcc_jit_rvalue *b, */ -/* basic_block_t *then_target, basic_block_t *else_target) */ +/* gcc_jit_block *then_target, gcc_jit_block *else_target) */ /* { */ /* gcc_jit_rvalue *test = gcc_jit_context_new_comparison (comp.ctxt, */ /* NULL, */ @@ -381,7 +350,7 @@ emit_cast (gcc_jit_type *new_type, gcc_jit_rvalue *obj) NULL, comp.cast_union_type, format_string ("union_cast_%u", i++)); - gcc_jit_block_add_assignment (comp.block->gcc_bb, + gcc_jit_block_add_assignment (comp.block, NULL, gcc_jit_lvalue_access_field (tmp_u, NULL, @@ -717,7 +686,7 @@ emit_CONSP (gcc_jit_rvalue *obj) /* comp.lisp_obj_type, */ /* "lisp_obj_fixnum"); */ -/* gcc_jit_block_add_assignment (comp.block->gcc_bb, */ +/* gcc_jit_block_add_assignment (comp.block, */ /* NULL, */ /* emit_lval_XLI (res), */ /* tmp); */ @@ -747,7 +716,7 @@ emit_lisp_obj_from_ptr (void *p) format_string ("Symbol %s", (char *) SDATA (SYMBOL_NAME (p)))); - gcc_jit_block_add_assignment (comp.block->gcc_bb, + gcc_jit_block_add_assignment (comp.block, NULL, emit_lval_XLP (lisp_obj), void_ptr); @@ -867,7 +836,7 @@ emit_CHECK_CONS (gcc_jit_rvalue *x) x }; gcc_jit_block_add_eval ( - comp.block->gcc_bb, + comp.block, NULL, gcc_jit_context_new_call (comp.ctxt, NULL, @@ -898,7 +867,7 @@ emit_XSETCAR (gcc_jit_rvalue *c, gcc_jit_rvalue *n) emit_comment ("XSETCAR"); gcc_jit_block_add_assignment( - comp.block->gcc_bb, + comp.block, NULL, gcc_jit_rvalue_dereference ( emit_car_addr (c), @@ -912,7 +881,7 @@ emit_XSETCDR (gcc_jit_rvalue *c, gcc_jit_rvalue *n) emit_comment ("XSETCDR"); gcc_jit_block_add_assignment( - comp.block->gcc_bb, + comp.block, NULL, gcc_jit_rvalue_dereference ( emit_cdr_addr (c), @@ -955,7 +924,29 @@ emit_PURE_P (gcc_jit_rvalue *ptr) /* return emit_call (f_name, comp.lisp_obj_type, 2, args); */ /* } */ -/* /\* struct Lisp_Cons definition. *\/ */ +static void +emit_limple_inst (Lisp_Object inst) +{ + Lisp_Object op = XCAR (inst); + Lisp_Object arg0 = XCAR (XCDR (inst)); + + if (EQ (op, Qblock)) + { + char *block_name = SDATA (SYMBOL_NAME (arg0)); + comp.block = gcc_jit_function_new_block (comp.func, block_name); + } + else if (EQ (op, Qeqcall)) + { + } + else if (EQ (op, Qeqconst)) + { + } + else if (EQ (op, Qreturn)) + { + } +} + +/* struct Lisp_Cons definition. */ static void define_lisp_cons (void) @@ -1300,7 +1291,6 @@ define_cast_union (void) static void define_CHECK_TYPE (void) { - USE_SAFE_ALLOCA; gcc_jit_param *param[] = { gcc_jit_context_new_param (comp.ctxt, NULL, @@ -1326,29 +1316,27 @@ define_CHECK_TYPE (void) gcc_jit_rvalue *predicate = gcc_jit_param_as_rvalue (param[1]); gcc_jit_rvalue *x = gcc_jit_param_as_rvalue (param[2]); - DECL_AND_SAFE_ALLOCA_BLOCK (init_block, comp.check_type); - DECL_AND_SAFE_ALLOCA_BLOCK (ok_block, comp.check_type); - DECL_AND_SAFE_ALLOCA_BLOCK (not_ok_block, comp.check_type); + DECL_BLOCK (init_block, comp.check_type); + DECL_BLOCK (ok_block, comp.check_type); + DECL_BLOCK (not_ok_block, comp.check_type); comp.block = init_block; comp.func = comp.check_type; emit_cond_jump (ok, ok_block, not_ok_block); - gcc_jit_block_end_with_void_return (ok_block->gcc_bb, NULL); + gcc_jit_block_end_with_void_return (ok_block, NULL); comp.block = not_ok_block; gcc_jit_rvalue *wrong_type_args[] = { predicate, x }; - gcc_jit_block_add_eval (comp.block->gcc_bb, + gcc_jit_block_add_eval (comp.block, NULL, emit_call ("wrong_type_argument", comp.lisp_obj_type, 2, wrong_type_args)); - gcc_jit_block_end_with_void_return (not_ok_block->gcc_bb, NULL); - - SAFE_FREE (); + gcc_jit_block_end_with_void_return (not_ok_block, NULL); } @@ -1357,8 +1345,6 @@ define_CHECK_TYPE (void) static void define_CAR_CDR (void) { - USE_SAFE_ALLOCA; - gcc_jit_param *car_param = gcc_jit_context_new_param (comp.ctxt, NULL, @@ -1392,9 +1378,9 @@ define_CAR_CDR (void) for (int i = 0; i < 2; i++) { gcc_jit_rvalue *c = gcc_jit_param_as_rvalue (param); - DECL_AND_SAFE_ALLOCA_BLOCK (init_block, f); - DECL_AND_SAFE_ALLOCA_BLOCK (is_cons_b, f); - DECL_AND_SAFE_ALLOCA_BLOCK (not_a_cons_b, f); + DECL_BLOCK (init_block, f); + DECL_BLOCK (is_cons_b, f); + DECL_BLOCK (not_a_cons_b, f); comp.block = init_block; comp.func = f; @@ -1404,23 +1390,23 @@ define_CAR_CDR (void) comp.block = is_cons_b; if (f == comp.car) - gcc_jit_block_end_with_return (comp.block->gcc_bb, + gcc_jit_block_end_with_return (comp.block, NULL, emit_XCAR (c)); else - gcc_jit_block_end_with_return (comp.block->gcc_bb, + gcc_jit_block_end_with_return (comp.block, NULL, emit_XCDR (c)); comp.block = not_a_cons_b; - DECL_AND_SAFE_ALLOCA_BLOCK (is_nil_b, f); - DECL_AND_SAFE_ALLOCA_BLOCK (not_nil_b, f); + DECL_BLOCK (is_nil_b, f); + DECL_BLOCK (not_nil_b, f); emit_cond_jump (emit_NILP (c), is_nil_b, not_nil_b); comp.block = is_nil_b; - gcc_jit_block_end_with_return (comp.block->gcc_bb, + gcc_jit_block_end_with_return (comp.block, NULL, emit_lisp_obj_from_ptr (Qnil)); @@ -1428,25 +1414,21 @@ define_CAR_CDR (void) gcc_jit_rvalue *wrong_type_args[] = { emit_lisp_obj_from_ptr (Qlistp), c }; - gcc_jit_block_add_eval (comp.block->gcc_bb, + gcc_jit_block_add_eval (comp.block, NULL, emit_call ("wrong_type_argument", comp.lisp_obj_type, 2, wrong_type_args)); - gcc_jit_block_end_with_return (comp.block->gcc_bb, + gcc_jit_block_end_with_return (comp.block, NULL, emit_lisp_obj_from_ptr (Qnil)); f = comp.cdr; param = cdr_param; } - - SAFE_FREE (); } static void define_setcar_setcdr (void) { - USE_SAFE_ALLOCA; - char const *f_name[] = {"setcar", "setcdr"}; char const *par_name[] = {"new_car", "new_cdr"}; @@ -1473,7 +1455,7 @@ define_setcar_setcdr (void) 2, param, 0); - DECL_AND_SAFE_ALLOCA_BLOCK (init_block, *f_ref); + DECL_BLOCK (init_block, *f_ref); comp.func = *f_ref; comp.block = init_block; @@ -1486,7 +1468,7 @@ define_setcar_setcdr (void) emit_XCONS (gcc_jit_param_as_rvalue (cell)) }; gcc_jit_block_add_eval ( - init_block->gcc_bb, + init_block, NULL, gcc_jit_context_new_call (comp.ctxt, NULL, @@ -1503,11 +1485,10 @@ define_setcar_setcdr (void) gcc_jit_param_as_rvalue (new_el)); /* return newel; */ - gcc_jit_block_end_with_return (init_block->gcc_bb, + gcc_jit_block_end_with_return (init_block, NULL, gcc_jit_param_as_rvalue (new_el)); } - SAFE_FREE (); } /* Declare a substitute for PSEUDOVECTORP as always inlined function. */ @@ -1515,8 +1496,6 @@ define_setcar_setcdr (void) static void define_PSEUDOVECTORP (void) { - USE_SAFE_ALLOCA; - gcc_jit_param *param[] = { gcc_jit_context_new_param (comp.ctxt, NULL, @@ -1536,9 +1515,9 @@ define_PSEUDOVECTORP (void) param, 0); - DECL_AND_SAFE_ALLOCA_BLOCK (init_block, comp.pseudovectorp); - DECL_AND_SAFE_ALLOCA_BLOCK (ret_false_b, comp.pseudovectorp); - DECL_AND_SAFE_ALLOCA_BLOCK (call_pseudovector_typep_b, comp.pseudovectorp); + DECL_BLOCK (init_block, comp.pseudovectorp); + DECL_BLOCK (ret_false_b, comp.pseudovectorp); + DECL_BLOCK (call_pseudovector_typep_b, comp.pseudovectorp); comp.block = init_block; comp.func = comp.pseudovectorp; @@ -1548,7 +1527,7 @@ define_PSEUDOVECTORP (void) ret_false_b); comp.block = ret_false_b; - gcc_jit_block_end_with_return (ret_false_b->gcc_bb, + gcc_jit_block_end_with_return (ret_false_b, NULL, gcc_jit_context_new_rvalue_from_int( comp.ctxt, @@ -1560,21 +1539,18 @@ define_PSEUDOVECTORP (void) gcc_jit_param_as_rvalue (param[1]) }; comp.block = call_pseudovector_typep_b; /* FIXME use XUNTAG now that's available. */ - gcc_jit_block_end_with_return (call_pseudovector_typep_b->gcc_bb + gcc_jit_block_end_with_return (call_pseudovector_typep_b , NULL, emit_call ("helper_PSEUDOVECTOR_TYPEP_XUNTAG", comp.bool_type, 2, args)); - SAFE_FREE (); } static void define_CHECK_IMPURE (void) { - USE_SAFE_ALLOCA; - gcc_jit_param *param[] = { gcc_jit_context_new_param (comp.ctxt, NULL, @@ -1593,9 +1569,9 @@ define_CHECK_IMPURE (void) param, 0); - DECL_AND_SAFE_ALLOCA_BLOCK (init_block, comp.check_impure); - DECL_AND_SAFE_ALLOCA_BLOCK (err_block, comp.check_impure); - DECL_AND_SAFE_ALLOCA_BLOCK (ok_block, comp.check_impure); + DECL_BLOCK (init_block, comp.check_impure); + DECL_BLOCK (err_block, comp.check_impure); + DECL_BLOCK (ok_block, comp.check_impure); comp.block = init_block; comp.func = comp.check_impure; @@ -1603,29 +1579,26 @@ define_CHECK_IMPURE (void) emit_cond_jump (emit_PURE_P (gcc_jit_param_as_rvalue (param[0])), /* FIXME */ err_block, ok_block); - gcc_jit_block_end_with_void_return (ok_block->gcc_bb, NULL); + gcc_jit_block_end_with_void_return (ok_block, NULL); gcc_jit_rvalue *pure_write_error_arg = gcc_jit_param_as_rvalue (param[0]); comp.block = err_block; - gcc_jit_block_add_eval (comp.block->gcc_bb, + gcc_jit_block_add_eval (comp.block, NULL, emit_call ("pure_write_error", comp.void_type, 1, &pure_write_error_arg)); - gcc_jit_block_end_with_void_return (err_block->gcc_bb, NULL); - - SAFE_FREE ();} + gcc_jit_block_end_with_void_return (err_block, NULL); +} /* Declare a function to convert boolean into t or nil */ static void define_bool_to_lisp_obj (void) { - USE_SAFE_ALLOCA; - /* x ? Qt : Qnil */ gcc_jit_param *param = gcc_jit_context_new_param (comp.ctxt, NULL, @@ -1639,9 +1612,9 @@ define_bool_to_lisp_obj (void) 1, ¶m, 0); - DECL_AND_SAFE_ALLOCA_BLOCK (init_block, comp.bool_to_lisp_obj); - DECL_AND_SAFE_ALLOCA_BLOCK (ret_t_block, comp.bool_to_lisp_obj); - DECL_AND_SAFE_ALLOCA_BLOCK (ret_nil_block, comp.bool_to_lisp_obj); + DECL_BLOCK (init_block, comp.bool_to_lisp_obj); + DECL_BLOCK (ret_t_block, comp.bool_to_lisp_obj); + DECL_BLOCK (ret_nil_block, comp.bool_to_lisp_obj); comp.block = init_block; comp.func = comp.bool_to_lisp_obj; @@ -1650,16 +1623,15 @@ define_bool_to_lisp_obj (void) ret_nil_block); comp.block = ret_t_block; - gcc_jit_block_end_with_return (ret_t_block->gcc_bb, + gcc_jit_block_end_with_return (ret_t_block, NULL, emit_lisp_obj_from_ptr (Qt)); comp.block = ret_nil_block; - gcc_jit_block_end_with_return (ret_nil_block->gcc_bb, + gcc_jit_block_end_with_return (ret_nil_block, NULL, emit_lisp_obj_from_ptr (Qnil)); - SAFE_FREE (); } DEFUN ("comp-init-ctxt", Fcomp_init_ctxt, Scomp_init_ctxt, @@ -1832,6 +1804,56 @@ DEFUN ("comp-add-func-to-ctxt", Fcomp_add_func_to_ctxt, Scomp_add_func_to_ctxt, { char *c_name = (char *) SDATA (CALLN (Ffuncall, intern ("comp-func-c-func-name"), func)); + Lisp_Object args = (CALLN (Ffuncall, intern ("comp-func-args"), func)); + EMACS_INT frame_size = + XFIXNUM (CALLN (Ffuncall, intern ("comp-func-frame-size"), func)); + EMACS_INT min_args = + XFIXNUM (CALLN (Ffuncall, intern ("comp-args-min"), args)); + EMACS_INT max_args = + XFIXNUM (CALLN (Ffuncall, intern ("comp-args-max"), args)); + bool ncall = + !NILP (CALLN (Ffuncall, intern ("comp-args-ncall-conv"), args)); + + if (!ncall) + { + comp.func = + emit_func_declare (c_name, comp.lisp_obj_type, min_args, + NULL, GCC_JIT_FUNCTION_EXPORTED, false); + } + else + { + error ("Not supported for now"); + } + + gcc_jit_lvalue *meta_frame = + gcc_jit_function_new_local ( + comp.func, + NULL, + gcc_jit_context_new_array_type (comp.ctxt, + NULL, + comp.lisp_obj_type, + frame_size), + "local"); + + gcc_jit_lvalue *frame[frame_size]; + for (int i = 0; i < frame_size; ++i) + frame[i] = + gcc_jit_context_new_array_access ( + comp.ctxt, + NULL, + gcc_jit_lvalue_as_rvalue (meta_frame), + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.int_type, + i)); + + Lisp_Object limple = (CALLN (Ffuncall, intern ("comp-func-ir"), func)); + + while (CONSP (limple)) + { + Lisp_Object inst = XCAR (limple); + emit_limple_inst (inst); + limple = XCDR (limple); + }; return Qt; } @@ -1846,12 +1868,24 @@ DEFUN ("comp-compile-and-load-ctxt", Fcomp_compile_and_load_ctxt, gcc_jit_context_set_int_option (comp.ctxt, GCC_JIT_INT_OPTION_OPTIMIZATION_LEVEL, comp_speed); + /* Gcc doesn't like being interrupted. */ + sigset_t oldset; + block_atimers (&oldset); + + unblock_atimers (&oldset); + return Qt; } void syms_of_comp (void) { + /* Limple instruction set. */ + DEFSYM (Qblock, "BLOCK"); + DEFSYM (Qeqcall, "=call"); + DEFSYM (Qeqconst, "=const"); + DEFSYM (Qreturn, "return"); + defsubr (&Scomp_init_ctxt); defsubr (&Scomp_release_ctxt); defsubr (&Scomp_add_func_to_ctxt); commit ee04ef4f6f999250b714384285a76141510564ad Author: Andrea Corallo Date: Mon Jul 8 14:13:38 2019 +0200 comment out unused functions diff --git a/src/comp.c b/src/comp.c index ed7aef0aa9..e176967da7 100644 --- a/src/comp.c +++ b/src/comp.c @@ -230,17 +230,17 @@ emit_comment (const char *str) /* Assignments to the meta-stack slots should be emitted usign this to always */ /* reset annotation fields. */ -static void -emit_assign_to_stack_slot (basic_block_t *block, stack_el_t *slot, - gcc_jit_rvalue *val) -{ - gcc_jit_block_add_assignment (block->gcc_bb, - NULL, - slot->gcc_lval, - val); - slot->type = -1; - slot->const_set = false; -} +/* static void */ +/* emit_assign_to_stack_slot (basic_block_t *block, stack_el_t *slot, */ +/* gcc_jit_rvalue *val) */ +/* { */ +/* gcc_jit_block_add_assignment (block->gcc_bb, */ +/* NULL, */ +/* slot->gcc_lval, */ +/* val); */ +/* slot->type = -1; */ +/* slot->const_set = false; */ +/* } */ /* Declare a function with all args being Lisp_Object and returning a Lisp_Object. */ @@ -305,8 +305,8 @@ emit_call (const char *f_name, gcc_jit_type *ret_type, unsigned nargs, if (i == -1) { - emit_func_declare(f_name, ret_type, nargs, args, GCC_JIT_FUNCTION_IMPORTED, - true); + emit_func_declare (f_name, ret_type, nargs, args, + GCC_JIT_FUNCTION_IMPORTED, true); i = hash_lookup (ht, key, &hash); eassert (i != -1); } @@ -352,20 +352,20 @@ emit_cond_jump (gcc_jit_rvalue *test, /* Close current basic block emitting a comparison between two rval. */ -static gcc_jit_rvalue * -emit_comparison_jump (enum gcc_jit_comparison op, - gcc_jit_rvalue *a, gcc_jit_rvalue *b, - basic_block_t *then_target, basic_block_t *else_target) -{ - gcc_jit_rvalue *test = gcc_jit_context_new_comparison (comp.ctxt, - NULL, - op, - a, b); +/* static gcc_jit_rvalue * */ +/* emit_comparison_jump (enum gcc_jit_comparison op, */ +/* gcc_jit_rvalue *a, gcc_jit_rvalue *b, */ +/* basic_block_t *then_target, basic_block_t *else_target) */ +/* { */ +/* gcc_jit_rvalue *test = gcc_jit_context_new_comparison (comp.ctxt, */ +/* NULL, */ +/* op, */ +/* a, b); */ - emit_cond_jump (test, then_target, else_target); +/* emit_cond_jump (test, then_target, else_target); */ - return test; -} +/* return test; */ +/* } */ static gcc_jit_rvalue * emit_cast (gcc_jit_type *new_type, gcc_jit_rvalue *obj) @@ -399,34 +399,34 @@ emit_cast (gcc_jit_type *new_type, gcc_jit_rvalue *obj) (typeof_ptr) ((uintptr) ptr + size_of_ptr_ref * i) */ -static gcc_jit_rvalue * -emit_ptr_arithmetic (gcc_jit_rvalue *ptr, gcc_jit_type *ptr_type, - int size_of_ptr_ref, gcc_jit_rvalue *i) -{ - emit_comment ("ptr_arithmetic"); - - gcc_jit_rvalue *offset = - gcc_jit_context_new_binary_op ( - comp.ctxt, - NULL, - GCC_JIT_BINARY_OP_MULT, - comp.uintptr_type, - gcc_jit_context_new_rvalue_from_int (comp.ctxt, - comp.uintptr_type, - size_of_ptr_ref), - emit_cast (comp.uintptr_type, i)); - - return - emit_cast ( - ptr_type, - gcc_jit_context_new_binary_op ( - comp.ctxt, - NULL, - GCC_JIT_BINARY_OP_PLUS, - comp.uintptr_type, - emit_cast (comp.uintptr_type, ptr), - offset)); -} +/* static gcc_jit_rvalue * */ +/* emit_ptr_arithmetic (gcc_jit_rvalue *ptr, gcc_jit_type *ptr_type, */ +/* int size_of_ptr_ref, gcc_jit_rvalue *i) */ +/* { */ +/* emit_comment ("ptr_arithmetic"); */ + +/* gcc_jit_rvalue *offset = */ +/* gcc_jit_context_new_binary_op ( */ +/* comp.ctxt, */ +/* NULL, */ +/* GCC_JIT_BINARY_OP_MULT, */ +/* comp.uintptr_type, */ +/* gcc_jit_context_new_rvalue_from_int (comp.ctxt, */ +/* comp.uintptr_type, */ +/* size_of_ptr_ref), */ +/* emit_cast (comp.uintptr_type, i)); */ + +/* return */ +/* emit_cast ( */ +/* ptr_type, */ +/* gcc_jit_context_new_binary_op ( */ +/* comp.ctxt, */ +/* NULL, */ +/* GCC_JIT_BINARY_OP_PLUS, */ +/* comp.uintptr_type, */ +/* emit_cast (comp.uintptr_type, ptr), */ +/* offset)); */ +/* } */ INLINE static gcc_jit_rvalue * emit_XLI (gcc_jit_rvalue *obj) @@ -575,155 +575,155 @@ emit_CONSP (gcc_jit_rvalue *obj) return emit_TAGGEDP (obj, Lisp_Cons); } -static gcc_jit_rvalue * -emit_FLOATP (gcc_jit_rvalue *obj) -{ - emit_comment ("FLOATP"); - - return emit_TAGGEDP (obj, Lisp_Float); -} - -static gcc_jit_rvalue * -emit_BIGNUMP (gcc_jit_rvalue *obj) -{ - /* PSEUDOVECTORP (x, PVEC_BIGNUM); */ - emit_comment ("BIGNUMP"); - - gcc_jit_rvalue *args[2] = { - obj, - gcc_jit_context_new_rvalue_from_int (comp.ctxt, - comp.int_type, - PVEC_BIGNUM) }; - - return gcc_jit_context_new_call (comp.ctxt, - NULL, - comp.pseudovectorp, - 2, - args); -} - -static gcc_jit_rvalue * -emit_FIXNUMP (gcc_jit_rvalue *obj) -{ - /* (! (((unsigned) (XLI (x) >> (USE_LSB_TAG ? 0 : FIXNUM_BITS)) - - (unsigned) (Lisp_Int0 >> !USE_LSB_TAG)) - & ((1 << INTTYPEBITS) - 1))) */ - emit_comment ("FIXNUMP"); - - gcc_jit_rvalue *sh_res = - gcc_jit_context_new_binary_op ( - comp.ctxt, - NULL, - GCC_JIT_BINARY_OP_RSHIFT, - comp.emacs_int_type, - emit_XLI (obj), - gcc_jit_context_new_rvalue_from_int (comp.ctxt, - comp.emacs_int_type, - (USE_LSB_TAG ? 0 : FIXNUM_BITS))); - - gcc_jit_rvalue *minus_res = - gcc_jit_context_new_binary_op (comp.ctxt, - NULL, - GCC_JIT_BINARY_OP_MINUS, - comp.unsigned_type, - emit_cast (comp.unsigned_type, sh_res), - gcc_jit_context_new_rvalue_from_int ( - comp.ctxt, - comp.unsigned_type, - (Lisp_Int0 >> !USE_LSB_TAG))); - - gcc_jit_rvalue *res = - gcc_jit_context_new_unary_op ( - comp.ctxt, - NULL, - GCC_JIT_UNARY_OP_LOGICAL_NEGATE, - comp.int_type, - gcc_jit_context_new_binary_op (comp.ctxt, - NULL, - GCC_JIT_BINARY_OP_BITWISE_AND, - comp.unsigned_type, - minus_res, - gcc_jit_context_new_rvalue_from_int ( - comp.ctxt, - comp.unsigned_type, - ((1 << INTTYPEBITS) - 1)))); - - return res; -} - -static gcc_jit_rvalue * -emit_XFIXNUM (gcc_jit_rvalue *obj) -{ - emit_comment ("XFIXNUM"); - - return gcc_jit_context_new_binary_op (comp.ctxt, - NULL, - GCC_JIT_BINARY_OP_RSHIFT, - comp.emacs_int_type, - emit_XLI (obj), - comp.inttypebits); -} - -static gcc_jit_rvalue * -emit_INTEGERP (gcc_jit_rvalue *obj) -{ - emit_comment ("INTEGERP"); - - return gcc_jit_context_new_binary_op (comp.ctxt, - NULL, - GCC_JIT_BINARY_OP_LOGICAL_OR, - comp.bool_type, - emit_cast (comp.bool_type, - emit_FIXNUMP (obj)), - emit_BIGNUMP (obj)); -} - -static gcc_jit_rvalue * -emit_NUMBERP (gcc_jit_rvalue *obj) -{ - emit_comment ("NUMBERP"); - - return gcc_jit_context_new_binary_op (comp.ctxt, - NULL, - GCC_JIT_BINARY_OP_LOGICAL_OR, - comp.bool_type, - emit_INTEGERP(obj), - emit_cast (comp.bool_type, - emit_FLOATP (obj))); -} - -static gcc_jit_rvalue * -emit_make_fixnum (gcc_jit_rvalue *obj) -{ - emit_comment ("make_fixnum"); - - gcc_jit_rvalue *tmp = - gcc_jit_context_new_binary_op (comp.ctxt, - NULL, - GCC_JIT_BINARY_OP_LSHIFT, - comp.emacs_int_type, - obj, - comp.inttypebits); - - tmp = gcc_jit_context_new_binary_op (comp.ctxt, - NULL, - GCC_JIT_BINARY_OP_PLUS, - comp.emacs_int_type, - tmp, - comp.lisp_int0); - - gcc_jit_lvalue *res = gcc_jit_function_new_local (comp.func, - NULL, - comp.lisp_obj_type, - "lisp_obj_fixnum"); - - gcc_jit_block_add_assignment (comp.block->gcc_bb, - NULL, - emit_lval_XLI (res), - tmp); - - return gcc_jit_lvalue_as_rvalue (res); -} +/* static gcc_jit_rvalue * */ +/* emit_FLOATP (gcc_jit_rvalue *obj) */ +/* { */ +/* emit_comment ("FLOATP"); */ + +/* return emit_TAGGEDP (obj, Lisp_Float); */ +/* } */ + +/* static gcc_jit_rvalue * */ +/* emit_BIGNUMP (gcc_jit_rvalue *obj) */ +/* { */ +/* /\* PSEUDOVECTORP (x, PVEC_BIGNUM); *\/ */ +/* emit_comment ("BIGNUMP"); */ + +/* gcc_jit_rvalue *args[2] = { */ +/* obj, */ +/* gcc_jit_context_new_rvalue_from_int (comp.ctxt, */ +/* comp.int_type, */ +/* PVEC_BIGNUM) }; */ + +/* return gcc_jit_context_new_call (comp.ctxt, */ +/* NULL, */ +/* comp.pseudovectorp, */ +/* 2, */ +/* args); */ +/* } */ + +/* static gcc_jit_rvalue * */ +/* emit_FIXNUMP (gcc_jit_rvalue *obj) */ +/* { */ +/* /\* (! (((unsigned) (XLI (x) >> (USE_LSB_TAG ? 0 : FIXNUM_BITS)) */ +/* - (unsigned) (Lisp_Int0 >> !USE_LSB_TAG)) */ +/* & ((1 << INTTYPEBITS) - 1))) *\/ */ +/* emit_comment ("FIXNUMP"); */ + +/* gcc_jit_rvalue *sh_res = */ +/* gcc_jit_context_new_binary_op ( */ +/* comp.ctxt, */ +/* NULL, */ +/* GCC_JIT_BINARY_OP_RSHIFT, */ +/* comp.emacs_int_type, */ +/* emit_XLI (obj), */ +/* gcc_jit_context_new_rvalue_from_int (comp.ctxt, */ +/* comp.emacs_int_type, */ +/* (USE_LSB_TAG ? 0 : FIXNUM_BITS))); */ + +/* gcc_jit_rvalue *minus_res = */ +/* gcc_jit_context_new_binary_op (comp.ctxt, */ +/* NULL, */ +/* GCC_JIT_BINARY_OP_MINUS, */ +/* comp.unsigned_type, */ +/* emit_cast (comp.unsigned_type, sh_res), */ +/* gcc_jit_context_new_rvalue_from_int ( */ +/* comp.ctxt, */ +/* comp.unsigned_type, */ +/* (Lisp_Int0 >> !USE_LSB_TAG))); */ + +/* gcc_jit_rvalue *res = */ +/* gcc_jit_context_new_unary_op ( */ +/* comp.ctxt, */ +/* NULL, */ +/* GCC_JIT_UNARY_OP_LOGICAL_NEGATE, */ +/* comp.int_type, */ +/* gcc_jit_context_new_binary_op (comp.ctxt, */ +/* NULL, */ +/* GCC_JIT_BINARY_OP_BITWISE_AND, */ +/* comp.unsigned_type, */ +/* minus_res, */ +/* gcc_jit_context_new_rvalue_from_int ( */ +/* comp.ctxt, */ +/* comp.unsigned_type, */ +/* ((1 << INTTYPEBITS) - 1)))); */ + +/* return res; */ +/* } */ + +/* static gcc_jit_rvalue * */ +/* emit_XFIXNUM (gcc_jit_rvalue *obj) */ +/* { */ +/* emit_comment ("XFIXNUM"); */ + +/* return gcc_jit_context_new_binary_op (comp.ctxt, */ +/* NULL, */ +/* GCC_JIT_BINARY_OP_RSHIFT, */ +/* comp.emacs_int_type, */ +/* emit_XLI (obj), */ +/* comp.inttypebits); */ +/* } */ + +/* static gcc_jit_rvalue * */ +/* emit_INTEGERP (gcc_jit_rvalue *obj) */ +/* { */ +/* emit_comment ("INTEGERP"); */ + +/* return gcc_jit_context_new_binary_op (comp.ctxt, */ +/* NULL, */ +/* GCC_JIT_BINARY_OP_LOGICAL_OR, */ +/* comp.bool_type, */ +/* emit_cast (comp.bool_type, */ +/* emit_FIXNUMP (obj)), */ +/* emit_BIGNUMP (obj)); */ +/* } */ + +/* static gcc_jit_rvalue * */ +/* emit_NUMBERP (gcc_jit_rvalue *obj) */ +/* { */ +/* emit_comment ("NUMBERP"); */ + +/* return gcc_jit_context_new_binary_op (comp.ctxt, */ +/* NULL, */ +/* GCC_JIT_BINARY_OP_LOGICAL_OR, */ +/* comp.bool_type, */ +/* emit_INTEGERP(obj), */ +/* emit_cast (comp.bool_type, */ +/* emit_FLOATP (obj))); */ +/* } */ + +/* static gcc_jit_rvalue * */ +/* emit_make_fixnum (gcc_jit_rvalue *obj) */ +/* { */ +/* emit_comment ("make_fixnum"); */ + +/* gcc_jit_rvalue *tmp = */ +/* gcc_jit_context_new_binary_op (comp.ctxt, */ +/* NULL, */ +/* GCC_JIT_BINARY_OP_LSHIFT, */ +/* comp.emacs_int_type, */ +/* obj, */ +/* comp.inttypebits); */ + +/* tmp = gcc_jit_context_new_binary_op (comp.ctxt, */ +/* NULL, */ +/* GCC_JIT_BINARY_OP_PLUS, */ +/* comp.emacs_int_type, */ +/* tmp, */ +/* comp.lisp_int0); */ + +/* gcc_jit_lvalue *res = gcc_jit_function_new_local (comp.func, */ +/* NULL, */ +/* comp.lisp_obj_type, */ +/* "lisp_obj_fixnum"); */ + +/* gcc_jit_block_add_assignment (comp.block->gcc_bb, */ +/* NULL, */ +/* emit_lval_XLI (res), */ +/* tmp); */ + +/* return gcc_jit_lvalue_as_rvalue (res); */ +/* } */ /* Construct fill and return a lisp object form a raw pointer. */ static gcc_jit_rvalue * @@ -943,19 +943,19 @@ emit_PURE_P (gcc_jit_rvalue *ptr) PURESIZE)); } -static gcc_jit_rvalue * -emit_call_n_ref (const char *f_name, unsigned nargs, - gcc_jit_lvalue *base_arg) -{ - gcc_jit_rvalue *args[] = - { gcc_jit_context_new_rvalue_from_int(comp.ctxt, - comp.ptrdiff_type, - nargs), - gcc_jit_lvalue_get_address (base_arg, NULL) }; - return emit_call (f_name, comp.lisp_obj_type, 2, args); -} - -/* struct Lisp_Cons definition. */ +/* static gcc_jit_rvalue * */ +/* emit_call_n_ref (const char *f_name, unsigned nargs, */ +/* gcc_jit_lvalue *base_arg) */ +/* { */ +/* gcc_jit_rvalue *args[] = */ +/* { gcc_jit_context_new_rvalue_from_int(comp.ctxt, */ +/* comp.ptrdiff_type, */ +/* nargs), */ +/* gcc_jit_lvalue_get_address (base_arg, NULL) }; */ +/* return emit_call (f_name, comp.lisp_obj_type, 2, args); */ +/* } */ + +/* /\* struct Lisp_Cons definition. *\/ */ static void define_lisp_cons (void) commit 34e0be815db9c9ad8f8b98b52824aa3cf15a3ccc Author: Andrea Corallo Date: Mon Jul 8 12:11:34 2019 +0200 add comp-c-func-name diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index b6e3e01032..90713ec77b 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -54,11 +54,13 @@ (cl-defstruct (comp-func (:copier nil)) "Internal rapresentation for a function." (symbol-name nil - :documentation "Function symbol's name") + :documentation "Function symbol's name") + (c-func-name nil :type 'string + :documentation "The function name in the native world") (func nil - :documentation "Original form") + :documentation "Original form") (byte-func nil - :documentation "Byte compiled version") + :documentation "Byte compiled version") (ir nil :documentation "Current intermediate rappresentation") (args nil :type 'comp-args) @@ -86,6 +88,21 @@ (frame nil :type 'vector :documentation "Meta-stack used to flat LAP")) +(defun comp-c-func-name (symbol-function) + "Given SYMBOL-FUNCTION return a name suitable for the native code." + ;; Unfortunatelly not all symbol names are valid as C function names... + (let* ((orig-name (symbol-name symbol-function)) + (crypted (cl-loop with str = (make-string (* 2 (length orig-name)) 0) + for j from 0 by 2 + for i across orig-name + for byte = (format "%x" i) + do (aset str j (aref byte 0)) + do (aset str (1+ j) (aref byte 1)) + finally return str)) + (human-readable (replace-regexp-in-string + (rx (not (any "a-z"))) "" orig-name))) + (concat "F" crypted "_" human-readable))) + (defun comp-decrypt-lambda-list (x) "Decript lambda list X." (make-comp-args :rest (not (= (logand x 128) 0)) @@ -255,23 +272,24 @@ VAL is known at compile time." (defun native-compile (fun) "FUN is the function definition to be compiled into native code." (unless lexical-binding - (error "Can't compile a non lexical binded function")) + (error "Can't native compile a non lexical scoped function")) (if-let ((f (symbol-function fun))) (progn (when (byte-code-function-p f) (error "Can't native compile an already bytecompiled function")) (let ((func (make-comp-func :symbol-name fun - :func f))) + :func f + :c-func-name (comp-c-func-name fun)))) (mapc (lambda (pass) (funcall pass func)) comp-passes) ;; Once we have the final LIMPLE we jump into C. - (when (boundp #'comp-init-ctxt) - (comp-init-ctxt) - (comp-add-func-to-ctxt func) - (comp-compile-and-load-ctxt) - (comp-release-ctxt)))) - (error "Trying to native compile not a function"))) + (when t ;(boundp #'comp-init-ctxt) + (comp-init-ctxt) + (comp-add-func-to-ctxt func) + (comp-compile-and-load-ctxt) + (comp-release-ctxt)))) + (error "Trying to native compile something not a function"))) (provide 'comp) diff --git a/src/comp.c b/src/comp.c index 89d057217d..ed7aef0aa9 100644 --- a/src/comp.c +++ b/src/comp.c @@ -35,8 +35,6 @@ along with GNU Emacs. If not, see . */ #define COMP_DEBUG 1 -#define DISASS_FILE_NAME "emacs-asm.s" - #define SAFE_ALLOCA_BLOCK(ptr, func, name) \ do { \ (ptr) = SAFE_ALLOCA (sizeof (basic_block_t)); \ @@ -1832,6 +1830,9 @@ DEFUN ("comp-add-func-to-ctxt", Fcomp_add_func_to_ctxt, Scomp_add_func_to_ctxt, doc: /* Add limple FUNC to the current compilation context. */) (Lisp_Object func) { + char *c_name = + (char *) SDATA (CALLN (Ffuncall, intern ("comp-func-c-func-name"), func)); + return Qt; } commit a09816558395ee289897561627ac44fdf1775a6b Author: Andrea Corallo Date: Mon Jul 8 11:37:17 2019 +0200 calling C diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index fda4dc437b..b6e3e01032 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -23,7 +23,9 @@ ;;; Code: (require 'bytecomp) -(eval-when-compile (require 'cl-lib)) +(require 'cl-lib) +(require 'cl-extra) +(require 'subr-x) (defgroup comp nil "Emacs Lisp native compiler." @@ -102,6 +104,11 @@ (setf (comp-func-ir func) byte-compile-lap-output) func) +(declare-function comp-init-ctxt "comp.c") +(declare-function comp-release-ctxt "comp.c") +(declare-function comp-add-func-to-ctxt "comp.c") +(declare-function comp-compile-and-load-ctxt "comp.c") + ;; (defun comp-opt-call (inst) ;; "Optimize if possible a side-effect-free call in INST." ;; (cl-destructuring-bind (_ f &rest args) inst @@ -141,7 +148,7 @@ (cl-incf (comp-sp)) (setf (comp-slot) (make-comp-mvar :slot (comp-sp) - :type (alist-get (second src-slot) + :type (alist-get (cadr src-slot) comp-known-ret-types))) (push (list '=call (comp-slot) src-slot) comp-limple)) @@ -187,11 +194,11 @@ VAL is known at compile time." ('byte-dup (comp-push-slot-n (comp-sp))) ('byte-varref - (comp-push-call `(call Fsymbol_value ,(second inst)))) + (comp-push-call `(call Fsymbol_value ,(cadr inst)))) ;; ('byte-varset - ;; (comp-push-call `(call Fsymbol_value ,(second inst)))) + ;; (comp-push-call `(call Fsymbol_value ,(cadr inst)))) ('byte-constant - (comp-push-const (second inst))) + (comp-push-const (cadr inst))) ('byte-stack-ref (comp-push-slot-n (- (comp-sp) (cdr inst)))) ('byte-plus @@ -246,18 +253,24 @@ VAL is known at compile time." func)) (defun native-compile (fun) - "FUN is the function definition to be compiled to native code." + "FUN is the function definition to be compiled into native code." (unless lexical-binding (error "Can't compile a non lexical binded function")) (if-let ((f (symbol-function fun))) (progn (when (byte-code-function-p f) (error "Can't native compile an already bytecompiled function")) - (cl-loop with func = (make-comp-func :symbol-name fun - :func f) - for pass in comp-passes - do (funcall pass func) - finally return func)) + (let ((func (make-comp-func :symbol-name fun + :func f))) + (mapc (lambda (pass) + (funcall pass func)) + comp-passes) + ;; Once we have the final LIMPLE we jump into C. + (when (boundp #'comp-init-ctxt) + (comp-init-ctxt) + (comp-add-func-to-ctxt func) + (comp-compile-and-load-ctxt) + (comp-release-ctxt)))) (error "Trying to native compile not a function"))) (provide 'comp) diff --git a/src/comp.c b/src/comp.c index fb1fa79d12..89d057217d 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1835,9 +1835,11 @@ DEFUN ("comp-add-func-to-ctxt", Fcomp_add_func_to_ctxt, Scomp_add_func_to_ctxt, return Qt; } -DEFUN ("comp-compile-ctxt", Fcomp_compile_ctxt, Scomp_compile_ctxt, +DEFUN ("comp-compile-and-load-ctxt", Fcomp_compile_and_load_ctxt, + Scomp_compile_and_load_ctxt, 0, 1, 0, - doc: /* Compile as native code the current context. */) + doc: /* Compile as native code the current context and load its + functions. */) (Lisp_Object disassemble) { gcc_jit_context_set_int_option (comp.ctxt, @@ -1852,7 +1854,7 @@ syms_of_comp (void) defsubr (&Scomp_init_ctxt); defsubr (&Scomp_release_ctxt); defsubr (&Scomp_add_func_to_ctxt); - defsubr (&Scomp_compile_ctxt); + defsubr (&Scomp_compile_and_load_ctxt); comp.func_hash = Qnil; staticpro (&comp.func_hash); commit a9894ace841f89bdb1e4510ad48cb7fd76112ac0 Author: Andrea Corallo Date: Mon Jul 8 11:18:17 2019 +0200 purge C side diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 22dcfc77b3..fda4dc437b 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -136,7 +136,8 @@ '(comp-slot-n (1+ (comp-sp)))) (defun comp-push-call (src-slot) - "Push call X into frame." + "Push call SRC-SLOT into frame." + (cl-assert src-slot) (cl-incf (comp-sp)) (setf (comp-slot) (make-comp-mvar :slot (comp-sp) @@ -147,6 +148,7 @@ (defun comp-push-slot-n (n) "Push slot number N into frame." (let ((src-slot (comp-slot-n n))) + (cl-assert src-slot) (cl-incf (comp-sp)) (setf (comp-slot) (copy-sequence src-slot)) @@ -186,6 +188,8 @@ VAL is known at compile time." (comp-push-slot-n (comp-sp))) ('byte-varref (comp-push-call `(call Fsymbol_value ,(second inst)))) + ;; ('byte-varset + ;; (comp-push-call `(call Fsymbol_value ,(second inst)))) ('byte-constant (comp-push-const (second inst))) ('byte-stack-ref diff --git a/src/comp.c b/src/comp.c index 4837b12210..fb1fa79d12 100644 --- a/src/comp.c +++ b/src/comp.c @@ -31,138 +31,12 @@ along with GNU Emacs. If not, see . */ #include "atimer.h" #include "window.h" -#define DEFAULT_SPEED 2 /* From 0 to 3 map to gcc -O */ +#define DEFAULT_SPEED 2 /* See comp-speed var. */ #define COMP_DEBUG 1 -#define MAX_FUN_NAME 256 - -/* Max number of entries of the meta-stack that can get poped. */ - -#define MAX_POP 64 - #define DISASS_FILE_NAME "emacs-asm.s" -#define CHECK_STACK \ - eassert (stack >= stack_base && stack < stack_over) - -#define PUSH_LVAL(obj) \ - do { \ - CHECK_STACK; \ - emit_assign_to_stack_slot (comp.block, \ - stack, \ - gcc_jit_lvalue_as_rvalue (obj)); \ - stack++; \ - } while (0) - -#define PUSH_RVAL(obj) \ - do { \ - CHECK_STACK; \ - emit_assign_to_stack_slot (comp.block, stack, (obj)); \ - stack++; \ - } while (0) - -/* This always happens in the first basic block. */ - -#define PUSH_PARAM(obj) \ - do { \ - CHECK_STACK; \ - emit_assign_to_stack_slot (prologue, \ - stack, \ - gcc_jit_param_as_rvalue (obj)); \ - stack++; \ - } while (0) - -#define TOS (*(stack - 1)) - -#define DISCARD(n) (stack -= (n)) - -#define POP0 - -#define POP1 \ - do { \ - stack--; \ - CHECK_STACK; \ - args[0] = gcc_jit_lvalue_as_rvalue (stack->gcc_lval); \ - } while (0) - -#define POP2 \ - do { \ - stack--; \ - CHECK_STACK; \ - args[1] = gcc_jit_lvalue_as_rvalue (stack->gcc_lval); \ - stack--; \ - args[0] = gcc_jit_lvalue_as_rvalue (stack->gcc_lval); \ - } while (0) - -#define POP3 \ - do { \ - stack--; \ - CHECK_STACK; \ - args[2] = gcc_jit_lvalue_as_rvalue (stack->gcc_lval); \ - stack--; \ - args[1] = gcc_jit_lvalue_as_rvalue (stack->gcc_lval); \ - stack--; \ - args[0] = gcc_jit_lvalue_as_rvalue (stack->gcc_lval); \ - } while (0) - -/* Fetch the next byte from the bytecode stream. */ - -#define FETCH (bytestr_data[pc++]) - -/* Fetch two bytes from the bytecode stream and make a 16-bit number - out of them. */ - -#define FETCH2 (op = FETCH, op + (FETCH << 8)) - -#define STR(s) #s - -/* With most of the ops we need to do the same stuff so this macros are meant - to save some typing. */ - -#define CASE(op) \ - case op : \ - emit_comment (STR(op)) - -/* Pop from the meta-stack, emit the call and push the result */ - -#define EMIT_CALL_N(name, nargs) \ - do { \ - POP##nargs; \ - res = emit_call ((name), comp.lisp_obj_type, (nargs), args); \ - PUSH_RVAL (res); \ - } while (0) - -/* Generate appropriate case and emit call to function. */ - -#define CASE_CALL_N(name, nargs) \ - CASE (B##name); \ - EMIT_CALL_N (STR(F##name), nargs); \ - break - -/* - Emit calls to functions with prototype (ptrdiff_t nargs, Lisp_Object *args). - This is done by passing a reference to the first obj involved on the stack. -*/ - -#define EMIT_CALL_N_REF(name, nargs) \ - do { \ - DISCARD (nargs); \ - res = emit_call_n_ref ((name), (nargs), stack->gcc_lval); \ - PUSH_RVAL (res); \ - } while (0) - -#define EMIT_ARITHCOMPARE(comparison) \ - do { \ - POP2; \ - args[2] = gcc_jit_context_new_rvalue_from_int (comp.ctxt, \ - comp.int_type, \ - (comparison)); \ - res = emit_call ("arithcompare", comp.lisp_obj_type, 3, args); \ - PUSH_RVAL (res); \ - } while (0) - - #define SAFE_ALLOCA_BLOCK(ptr, func, name) \ do { \ (ptr) = SAFE_ALLOCA (sizeof (basic_block_t)); \ @@ -171,6 +45,8 @@ do { \ (ptr)->top = NULL; \ } while (0) +#define STR(s) #s + #define DECL_AND_SAFE_ALLOCA_BLOCK(name, func) \ basic_block_t *(name); \ SAFE_ALLOCA_BLOCK ((name), (func), STR(name)) @@ -304,24 +180,6 @@ bcall0 (Lisp_Object f) Ffuncall (1, &f); } -/* Pop form the main evaluation stack and place the elements in args in reversed - order. */ - -INLINE static void -pop (unsigned n, stack_el_t **stack_ref, gcc_jit_rvalue *args[]) -{ - eassert (n <= MAX_POP); /* FIXME? */ - stack_el_t *stack = *stack_ref; - - while (n--) - { - stack--; - args[n] = gcc_jit_lvalue_as_rvalue (stack->gcc_lval); - } - - *stack_ref = stack; -} - INLINE static gcc_jit_field * type_to_cast_field (gcc_jit_type *type) { @@ -1806,150 +1664,16 @@ define_bool_to_lisp_obj (void) SAFE_FREE (); } -static int -ucmp(const void *a, const void *b) -{ -#define _I(x) *(const int*)x - return _I(a) < _I(b) ? -1 : _I(a) > _I(b); -#undef _I -} - -/* Compute and initialize all basic blocks. */ -static basic_block_t * -compute_blocks (ptrdiff_t bytestr_length, unsigned char *bytestr_data, - Lisp_Object *vectorp, ptrdiff_t const_length) +DEFUN ("comp-init-ctxt", Fcomp_init_ctxt, Scomp_init_ctxt, + 0, 0, 0, + doc: /* Initialize the native compiler context. Return t on success. */) + (void) { - ptrdiff_t pc = 0; - unsigned op; - bool new_bb = true; - basic_block_t *bb_map = xmalloc (bytestr_length * sizeof (basic_block_t)); - unsigned *bb_start_pc = xmalloc (bytestr_length * sizeof (unsigned)); - unsigned bb_n = 0; - - while (pc < bytestr_length) - { - if (new_bb) - { - bb_start_pc[bb_n++] = pc; - new_bb = false; - } - - op = FETCH; - switch (op) - { - /* 3 byte non branch ops */ - case Bvarref7: - case Bvarset7: - case Bvarbind7: - case Bcall7: - case Bunbind7: - case Bstack_ref7: - case Bstack_set2: - pc += 2; - break; - /* 2 byte non branch ops */ - case Bvarref6: - case Bvarset6: - case Bvarbind6: - case Bcall6: - case Bunbind6: - case BlistN: - case BconcatN: - case BinsertN: - case Bstack_ref6: - case Bstack_set: - case BdiscardN: - ++pc; - break; - /* Absolute branches */ - case Bgoto: - case Bgotoifnil: - case Bgotoifnonnil: - case Bgotoifnilelsepop: - case Bgotoifnonnilelsepop: - case Bpushcatch: - case Bpushconditioncase: - op = FETCH2; - bb_start_pc[bb_n++] = op; - new_bb = true; - break; - /* PC relative branches */ - case BRgoto: - case BRgotoifnil: - case BRgotoifnonnil: - case BRgotoifnilelsepop: - case BRgotoifnonnilelsepop: - op = FETCH - 128; - bb_start_pc[bb_n++] = op; - new_bb = true; - break; - /* Other ops changing bb */ - case Bsub1: - case Badd1: - case Bnegate: - case Breturn: - new_bb = true; - break; - case Bswitch: - /* Handled in Bconstant case. */ - emacs_abort (); - break; - case Bconstant2: - op = FETCH2; - FALLTHROUGH; - default: - case Bconstant: - { - if (bytestr_data[pc] != Bswitch) - break; - /* Jump table with following Bswitch. */ - ++pc; - op -= Bconstant; - struct Lisp_Hash_Table *h = XHASH_TABLE (vectorp[op]); - for (ptrdiff_t i = 0; i < HASH_TABLE_SIZE (h); ++i) - if (!NILP (HASH_HASH (h, i))) - { - Lisp_Object pc = HASH_VALUE (h, i); - bb_start_pc[bb_n++] = XFIXNUM (pc); - } - bb_start_pc[bb_n++] = pc; - ++pc; - } - } - } - - /* Sort and remove possible duplicates. */ - qsort (bb_start_pc, bb_n, sizeof(unsigned), ucmp); - { - unsigned i, j; - for (i = j = 0; i < bb_n; i++) - if (bb_start_pc[i] != bb_start_pc[j]) - bb_start_pc[++j] = bb_start_pc[i]; - bb_n = j + 1; - } - - basic_block_t curr_bb; - for (int i = 0, pc = 0; pc < bytestr_length; pc++) + if (comp.ctxt) { - if (i < bb_n && pc == bb_start_pc[i]) - { - ++i; - curr_bb.gcc_bb = - gcc_jit_function_new_block (comp.func, format_string ("bb_%d", i)); - curr_bb.top = NULL; - curr_bb.terminated = false; - } - bb_map[pc] = curr_bb; + error ("Compiler context already taken."); + return Qnil; } - - xfree (bb_start_pc); - - return bb_map; -} - -static void -init_comp (int opt_level) -{ comp.ctxt = gcc_jit_context_acquire(); if (COMP_DEBUG) @@ -1974,14 +1698,9 @@ init_comp (int opt_level) } - gcc_jit_context_set_int_option (comp.ctxt, - GCC_JIT_INT_OPTION_OPTIMIZATION_LEVEL, - opt_level); - /* Do not inline within a compilation unit. */ gcc_jit_context_add_command_line_option (comp.ctxt, "-fno-inline"); - comp.void_type = gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_VOID); comp.void_ptr_type = gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_VOID_PTR); @@ -2089,1438 +1808,58 @@ init_comp (int opt_level) define_CHECK_IMPURE (); define_bool_to_lisp_obj (); define_setcar_setcdr(); + + return Qt; } -static void -release_comp (void) +DEFUN ("comp-release-ctxt", Fcomp_release_ctxt, Scomp_release_ctxt, + 0, 0, 0, + doc: /* Release the native compiler context. */) + (void) { if (comp.ctxt) gcc_jit_context_release(comp.ctxt); if (logfile) fclose (logfile); -} - -static comp_f_res_t -compile_f (const char *lisp_f_name, const char *c_f_name, - ptrdiff_t bytestr_length, unsigned char *bytestr_data, - EMACS_INT stack_depth, Lisp_Object *vectorp, - ptrdiff_t const_length, Lisp_Object args_template) -{ - USE_SAFE_ALLOCA; - gcc_jit_rvalue *res; - comp_f_res_t comp_res = { NULL, 0, 0 }; - ptrdiff_t pc = 0; - gcc_jit_rvalue *args[MAX_POP]; - unsigned op; - unsigned pushhandler_n = 0; - comp_res.min_args = 0; - comp_res.max_args = MANY; - - /* Meta-stack we use to flat the bytecode written for push and pop - Emacs VM.*/ - stack_el_t *stack_base, *stack, *stack_over; - SAFE_NALLOCA (stack_base, sizeof (stack_el_t), stack_depth); - stack = stack_base; - stack_over = stack_base + stack_depth; - - bool parse_args = true; - if (FIXNUMP (args_template)) - { - ptrdiff_t at = XFIXNUM (args_template); - bool rest = (at & 128) != 0; - int mandatory = at & 127; - ptrdiff_t nonrest = at >> 8; - - comp_res.min_args = mandatory; - - if (!rest && nonrest < SUBR_MAX_ARGS) - { - comp_res.max_args = nonrest; - parse_args = false; - } - } + comp.ctxt = NULL; - if (!parse_args) - { - comp.func = - emit_func_declare (c_f_name, comp.lisp_obj_type, comp_res.max_args, - NULL, GCC_JIT_FUNCTION_EXPORTED, false); - } - else - { - gcc_jit_param *param[] = - { gcc_jit_context_new_param (comp.ctxt, - NULL, - comp.ptrdiff_type, - "nargs"), - gcc_jit_context_new_param (comp.ctxt, - NULL, - comp.lisp_obj_ptr_type, - "args") }; - comp.func = - gcc_jit_context_new_function (comp.ctxt, - NULL, - GCC_JIT_FUNCTION_EXPORTED, - comp.lisp_obj_type, - c_f_name, - 2, - param, - 0); - } - - - gcc_jit_lvalue *meta_stack_array = - gcc_jit_function_new_local ( - comp.func, - NULL, - gcc_jit_context_new_array_type (comp.ctxt, - NULL, - comp.lisp_obj_type, - stack_depth), - "local"); - - for (int i = 0; i < stack_depth; ++i) - stack[i].gcc_lval = gcc_jit_context_new_array_access ( - comp.ctxt, - NULL, - gcc_jit_lvalue_as_rvalue (meta_stack_array), - gcc_jit_context_new_rvalue_from_int (comp.ctxt, - comp.int_type, - i)); - - DECL_AND_SAFE_ALLOCA_BLOCK(prologue, comp.func); - comp.block = prologue; - - basic_block_t *bb_map = - compute_blocks (bytestr_length, bytestr_data, vectorp, const_length); - - if (!parse_args) - { - for (ptrdiff_t i = 0; i < comp_res.max_args; ++i) - PUSH_PARAM (gcc_jit_function_get_param (comp.func, i)); - } - else - { - /* - nargs will be known at runtime therfore we emit: - - prologue: - local[0] = *args; - ++args; - . - . - . - local[min_args - 1] = *args; - ++args; - local[min_args] = list (nargs - min_args, args); - bb_1: - . - . - . - */ - gcc_jit_lvalue *nargs = - gcc_jit_param_as_lvalue (gcc_jit_function_get_param (comp.func, 0)); - gcc_jit_lvalue *args = - gcc_jit_param_as_lvalue (gcc_jit_function_get_param (comp.func, 1)); - gcc_jit_rvalue *min_args = - gcc_jit_context_new_rvalue_from_int (comp.ctxt, - comp.ptrdiff_type, - comp_res.min_args); - - for (ptrdiff_t i = 0; i < comp_res.min_args; ++i) - { - PUSH_LVAL (gcc_jit_rvalue_dereference ( - gcc_jit_lvalue_as_rvalue (args), - NULL)); - gcc_jit_block_add_assignment (prologue->gcc_bb, - NULL, - args, - emit_ptr_arithmetic ( - gcc_jit_lvalue_as_rvalue (args), - comp.lisp_obj_ptr_type, - sizeof (Lisp_Object), - comp.one)); - } - - /* - rest arguments - */ - gcc_jit_rvalue *list_args[] = - { gcc_jit_context_new_binary_op (comp.ctxt, - NULL, - GCC_JIT_BINARY_OP_MINUS, - comp.ptrdiff_type, - gcc_jit_lvalue_as_rvalue (nargs), - min_args), - gcc_jit_lvalue_as_rvalue (args) }; - - PUSH_RVAL (emit_call ("Flist", comp.lisp_obj_type, 2, list_args)); - } - gcc_jit_block_end_with_jump (prologue->gcc_bb, NULL, bb_map[0].gcc_bb); - comp.block = &bb_map[0]; - gcc_jit_rvalue *nil = emit_lisp_obj_from_ptr (Qnil); - - comp.block = NULL; - - while (pc < bytestr_length) - { - enum handlertype type; - - /* If we are changing BB and the last was one wasn't terminated - terminate it with a fall through. */ - if (comp.block && comp.block->gcc_bb != bb_map[pc].gcc_bb && - !comp.block->terminated) - { - gcc_jit_block_end_with_jump (comp.block->gcc_bb, NULL, bb_map[pc].gcc_bb); - comp.block->terminated = true; - } - comp.block = &bb_map[pc]; - if (bb_map[pc].top) - stack = bb_map[pc].top; - op = FETCH; - - switch (op) - { - CASE (Bstack_ref1); - goto stack_ref; - CASE (Bstack_ref2); - goto stack_ref; - CASE (Bstack_ref3); - goto stack_ref; - CASE (Bstack_ref4); - goto stack_ref; - CASE (Bstack_ref5); - stack_ref: - PUSH_LVAL ( - stack_base[(stack - stack_base) - (op - Bstack_ref) - 1].gcc_lval); - break; - - CASE (Bstack_ref6); - PUSH_LVAL (stack_base[(stack - stack_base) - FETCH - 1].gcc_lval); - break; - - CASE (Bstack_ref7); - PUSH_LVAL (stack_base[(stack - stack_base) - FETCH2 - 1].gcc_lval); - break; - - CASE (Bvarref7); - op = FETCH2; - goto varref; - - CASE (Bvarref); - goto varref_count; - CASE (Bvarref1); - goto varref_count; - CASE (Bvarref2); - goto varref_count; - CASE (Bvarref3); - goto varref_count; - CASE (Bvarref4); - goto varref_count; - CASE (Bvarref5); - varref_count: - op -= Bvarref; - goto varref; - - CASE (Bvarref6); - op = FETCH; - varref: - { - args[0] = emit_lisp_obj_from_ptr (vectorp[op]); - res = emit_call ("Fsymbol_value", comp.lisp_obj_type, 1, args); - PUSH_RVAL (res); - break; - } - - CASE (Bvarset); - goto varset_count; - CASE (Bvarset1); - goto varset_count; - CASE (Bvarset2); - goto varset_count; - CASE (Bvarset3); - goto varset_count; - CASE (Bvarset4); - goto varset_count; - CASE (Bvarset5); - varset_count: - op -= Bvarset; - goto varset; - - CASE (Bvarset7); - op = FETCH2; - goto varset; - - CASE (Bvarset6); - op = FETCH; - varset: - { - POP1; - args[1] = args[0]; - args[0] = emit_lisp_obj_from_ptr (vectorp[op]); - args[2] = nil; - args[3] = gcc_jit_context_new_rvalue_from_int (comp.ctxt, - comp.int_type, - SET_INTERNAL_SET); - res = emit_call ("set_internal", comp.lisp_obj_type, 4, args); - PUSH_RVAL (res); - } - break; - - CASE (Bvarbind6); - op = FETCH; - goto varbind; - - CASE (Bvarbind7); - op = FETCH2; - goto varbind; - - CASE (Bvarbind); - goto varbind_count; - CASE (Bvarbind1); - goto varbind_count; - CASE (Bvarbind2); - goto varbind_count; - CASE (Bvarbind3); - goto varbind_count; - CASE (Bvarbind4); - goto varbind_count; - CASE (Bvarbind5); - varbind_count: - op -= Bvarbind; - varbind: - { - args[0] = emit_lisp_obj_from_ptr (vectorp[op]); - pop (1, &stack, &args[1]); - res = emit_call ("specbind", comp.lisp_obj_type, 2, args); - PUSH_RVAL (res); - break; - } - - CASE (Bcall6); - op = FETCH; - goto docall; - - CASE (Bcall7); - op = FETCH2; - goto docall; - - CASE (Bcall); - goto docall_count; - CASE (Bcall1); - goto docall_count; - CASE (Bcall2); - goto docall_count; - CASE (Bcall3); - goto docall_count; - CASE (Bcall4); - goto docall_count; - CASE (Bcall5); - docall_count: - op -= Bcall; - docall: - { - res = NULL; - pop (op + 1, &stack, args); - if (stack->const_set && - stack->type == Lisp_Symbol) - { - char *sym_name = (char *) SDATA (SYMBOL_NAME (stack->constant)); - if (!strcmp (sym_name, - lisp_f_name)) - { - /* Optimize self calls. */ - res = gcc_jit_context_new_call (comp.ctxt, - NULL, - comp.func, - op, - args + 1); - } else if (SUBRP ((XSYMBOL (stack->constant)->u.s.function))) - { - /* Optimize primitive native calls. */ - emit_comment (format_string ("Calling primitive %s", - sym_name)); - /* FIXME we really should check is a primitive too!! */ - struct Lisp_Subr *subr = - XSUBR ((XSYMBOL (stack->constant)->u.s.function)); - if (subr->max_args == MANY) - { - /* f (nargs, args); */ - args[0] = - gcc_jit_context_new_rvalue_from_int ( - comp.ctxt, - comp.ptrdiff_type, - op); - args[1] = - gcc_jit_lvalue_get_address ((stack + 1)->gcc_lval, - NULL); - gcc_jit_type *types[] = - { comp.ptrdiff_type, comp.lisp_obj_ptr_type }; - gcc_jit_type *fn_ptr_type = - gcc_jit_context_new_function_ptr_type ( - comp.ctxt, - NULL, - comp.lisp_obj_type, - 2, types, 0); - res = - gcc_jit_context_new_call_through_ptr ( - comp.ctxt, - NULL, - gcc_jit_context_new_rvalue_from_ptr ( - comp.ctxt, - fn_ptr_type, - subr->function.a0), - 2, args); - } else - { - gcc_jit_type *types[op]; - - for (int i = 0; i < op; i++) - types[i] = comp.lisp_obj_type; - - gcc_jit_type *fn_ptr_type = - gcc_jit_context_new_function_ptr_type ( - comp.ctxt, - NULL, - comp.lisp_obj_type, - op, - types, - 0); - res = - gcc_jit_context_new_call_through_ptr ( - comp.ctxt, - NULL, - gcc_jit_context_new_rvalue_from_ptr ( - comp.ctxt, - fn_ptr_type, - subr->function.a0), - op, - args + 1); - } - } - } - /* Fall back to regular funcall dispatch mechanism. */ - if (!res) - res = emit_call_n_ref ("Ffuncall", op + 1, stack->gcc_lval); - - PUSH_RVAL (res); - break; - } - - CASE (Bunbind6); - op = FETCH; - goto dounbind; - - CASE (Bunbind7); - op = FETCH2; - goto dounbind; - - CASE (Bunbind); - goto dounbind_count; - CASE (Bunbind1); - goto dounbind_count; - CASE (Bunbind2); - goto dounbind_count; - CASE (Bunbind3); - goto dounbind_count; - CASE (Bunbind4); - goto dounbind_count; - CASE (Bunbind5); - dounbind_count: - op -= Bunbind; - dounbind: - { - args[0] = gcc_jit_context_new_rvalue_from_int(comp.ctxt, - comp.ptrdiff_type, - op); - - emit_call ("helper_unbind_n", comp.lisp_obj_type, 1, args); - } - break; - - CASE (Bpophandler); - { - /* current_thread->m_handlerlist = - current_thread->m_handlerlist->next; */ - gcc_jit_lvalue *m_handlerlist = - gcc_jit_rvalue_dereference_field (comp.current_thread, - NULL, - comp.m_handlerlist); - - gcc_jit_block_add_assignment( - comp.block->gcc_bb, - NULL, - m_handlerlist, - gcc_jit_lvalue_as_rvalue ( - gcc_jit_rvalue_dereference_field ( - gcc_jit_lvalue_as_rvalue (m_handlerlist), - NULL, - comp.handler_next_field))); - break; - } - - CASE (Bpushconditioncase); /* New in 24.4. */ - type = CONDITION_CASE; - goto pushhandler; - - CASE (Bpushcatch); /* New in 24.4. */ - type = CATCHER; - pushhandler: - { - /* struct handler *c = push_handler (POP, type); */ - int handler_pc = FETCH2; - gcc_jit_lvalue *c = - gcc_jit_function_new_local (comp.func, - NULL, - comp.handler_ptr_type, - format_string ("c_%u", - pushhandler_n)); - POP1; - args[1] = gcc_jit_context_new_rvalue_from_int (comp.ctxt, - comp.int_type, - type); - gcc_jit_block_add_assignment ( - comp.block->gcc_bb, - NULL, - c, - emit_call ("push_handler", comp.handler_ptr_type, 2, args)); - - args[0] = - gcc_jit_lvalue_get_address ( - gcc_jit_rvalue_dereference_field ( - gcc_jit_lvalue_as_rvalue (c), - NULL, - comp.handler_jmp_field), - NULL); -#ifdef HAVE__SETJMP - res = emit_call ("_setjmp", comp.int_type, 1, args); -#else - res = emit_call ("setjmp", comp.int_type, 1, args); -#endif - basic_block_t *push_h_val_block; - SAFE_ALLOCA_BLOCK (push_h_val_block, - comp.func, - format_string ("push_h_val_%u", - pushhandler_n)); - - emit_cond_jump (res, push_h_val_block, &bb_map[pc]); - - stack_el_t *stack_to_restore = stack; - /* This emit the handler part. */ - - basic_block_t *bb_orig = comp.block; - comp.block = push_h_val_block; - /* current_thread->m_handlerlist = c->next; */ - gcc_jit_lvalue *m_handlerlist = - gcc_jit_rvalue_dereference_field (comp.current_thread, - NULL, - comp.m_handlerlist); - gcc_jit_block_add_assignment (comp.block->gcc_bb, - NULL, - m_handlerlist, - gcc_jit_lvalue_as_rvalue( - gcc_jit_rvalue_dereference_field ( - gcc_jit_lvalue_as_rvalue (c), - NULL, - comp.handler_next_field))); - /* PUSH (c->val); */ - PUSH_LVAL (gcc_jit_rvalue_dereference_field ( - gcc_jit_lvalue_as_rvalue (c), - NULL, - comp.handler_val_field)); - bb_map[handler_pc].top = stack; - comp.block = bb_orig; - - gcc_jit_block_end_with_jump (push_h_val_block->gcc_bb, NULL, - bb_map[handler_pc].gcc_bb); - - stack = stack_to_restore; - ++pushhandler_n; - } - break; - - CASE_CALL_N (nth, 2); - CASE_CALL_N (symbolp, 1); - - CASE (Bconsp); - POP1; - res = emit_cast (comp.bool_type, - emit_CONSP (args[0])); - res = gcc_jit_context_new_call (comp.ctxt, - NULL, - comp.bool_to_lisp_obj, - 1, &res); - PUSH_RVAL (res); - break; - - CASE_CALL_N (stringp, 1); - CASE_CALL_N (listp, 1); - CASE_CALL_N (eq, 2); - CASE_CALL_N (memq, 1); - CASE_CALL_N (not, 1); - - case Bcar: - POP1; - res = gcc_jit_context_new_call (comp.ctxt, - NULL, - comp.car, - 1, args); - PUSH_RVAL (res); - break; - - case Bcdr: - POP1; - res = gcc_jit_context_new_call (comp.ctxt, - NULL, - comp.cdr, - 1, args); - PUSH_RVAL (res); - break; - - CASE_CALL_N (cons, 2); - - CASE (BlistN); - op = FETCH; - goto make_list; - - CASE (Blist1); - goto make_list_count; - CASE (Blist2); - goto make_list_count; - CASE (Blist3); - goto make_list_count; - CASE (Blist4); - make_list_count: - op = op - Blist1; - make_list: - { - POP1; - args[1] = nil; - res = emit_call ("Fcons", comp.lisp_obj_type, 2, args); - PUSH_RVAL (res); - for (int i = 0; i < op; ++i) - { - POP2; - res = emit_call ("Fcons", comp.lisp_obj_type, 2, args); - PUSH_RVAL (res); - } - break; - } - - CASE_CALL_N (length, 1); - CASE_CALL_N (aref, 2); - CASE_CALL_N (aset, 3); - CASE_CALL_N (symbol_value, 1); - CASE_CALL_N (symbol_function, 1); - CASE_CALL_N (set, 2); - CASE_CALL_N (fset, 2); - CASE_CALL_N (get, 2); - CASE_CALL_N (substring, 3); - - CASE (Bconcat2); - EMIT_CALL_N_REF ("Fconcat", 2); - break; - CASE (Bconcat3); - EMIT_CALL_N_REF ("Fconcat", 3); - break; - CASE (Bconcat4); - EMIT_CALL_N_REF ("Fconcat", 4); - break; - CASE (BconcatN); - op = FETCH; - EMIT_CALL_N_REF ("Fconcat", op); - break; - - CASE (Bsub1); - { - /* (FIXNUMP (TOP) && XFIXNUM (TOP) != MOST_NEGATIVE_FIXNUM - ? make_fixnum (XFIXNUM (TOP) - 1) - : Fsub1 (TOP)) */ - - DECL_AND_SAFE_ALLOCA_BLOCK (sub1_inline_block, comp.func); - DECL_AND_SAFE_ALLOCA_BLOCK (sub1_fcall_block, comp.func); - - gcc_jit_rvalue *tos_as_num = - emit_XFIXNUM (gcc_jit_lvalue_as_rvalue (TOS.gcc_lval)); - - emit_cond_jump ( - gcc_jit_context_new_binary_op ( - comp.ctxt, - NULL, - GCC_JIT_BINARY_OP_LOGICAL_AND, - comp.bool_type, - emit_cast (comp.bool_type, - emit_FIXNUMP (gcc_jit_lvalue_as_rvalue (TOS.gcc_lval))), - gcc_jit_context_new_comparison (comp.ctxt, - NULL, - GCC_JIT_COMPARISON_NE, - tos_as_num, - comp.most_negative_fixnum)), - sub1_inline_block, - sub1_fcall_block); - - gcc_jit_rvalue *sub1_inline_res = - gcc_jit_context_new_binary_op (comp.ctxt, - NULL, - GCC_JIT_BINARY_OP_MINUS, - comp.emacs_int_type, - tos_as_num, - comp.one); - - basic_block_t *bb_orig = comp.block; - - comp.block = sub1_inline_block; - emit_assign_to_stack_slot (sub1_inline_block, - &TOS, - emit_make_fixnum (sub1_inline_res)); - comp.block = sub1_fcall_block; - POP1; - res = emit_call ("Fsub1", comp.lisp_obj_type, 1, args); - PUSH_RVAL (res); - - gcc_jit_block_end_with_jump (sub1_inline_block->gcc_bb, - NULL, - bb_map[pc].gcc_bb); - gcc_jit_block_end_with_jump (sub1_fcall_block->gcc_bb, - NULL, - bb_map[pc].gcc_bb); - comp.block = bb_orig; - SAFE_FREE (); - } - - break; - CASE (Badd1); - { - /* (FIXNUMP (TOP) && XFIXNUM (TOP) != MOST_POSITIVE_FIXNUM - ? make_fixnum (XFIXNUM (TOP) + 1) - : Fadd (TOP)) */ - - DECL_AND_SAFE_ALLOCA_BLOCK (add1_inline_block, comp.func); - DECL_AND_SAFE_ALLOCA_BLOCK (add1_fcall_block, comp.func); - - gcc_jit_rvalue *tos_as_num = - emit_XFIXNUM (gcc_jit_lvalue_as_rvalue (TOS.gcc_lval)); - - emit_cond_jump ( - gcc_jit_context_new_binary_op ( - comp.ctxt, - NULL, - GCC_JIT_BINARY_OP_LOGICAL_AND, - comp.bool_type, - emit_cast (comp.bool_type, - emit_FIXNUMP (gcc_jit_lvalue_as_rvalue (TOS.gcc_lval))), - gcc_jit_context_new_comparison (comp.ctxt, - NULL, - GCC_JIT_COMPARISON_NE, - tos_as_num, - comp.most_positive_fixnum)), - add1_inline_block, - add1_fcall_block); - - gcc_jit_rvalue *add1_inline_res = - gcc_jit_context_new_binary_op (comp.ctxt, - NULL, - GCC_JIT_BINARY_OP_PLUS, - comp.emacs_int_type, - tos_as_num, - comp.one); - - basic_block_t *bb_orig = comp.block; - comp.block = add1_inline_block; - emit_assign_to_stack_slot(add1_inline_block, - &TOS, - emit_make_fixnum (add1_inline_res)); - comp.block = add1_fcall_block; - POP1; - res = emit_call ("Fadd1", comp.lisp_obj_type, 1, args); - PUSH_RVAL (res); - - gcc_jit_block_end_with_jump (add1_inline_block->gcc_bb, - NULL, - bb_map[pc].gcc_bb); - gcc_jit_block_end_with_jump (add1_fcall_block->gcc_bb, - NULL, - bb_map[pc].gcc_bb); - comp.block = bb_orig; - SAFE_FREE (); - } - break; - - CASE (Beqlsign); - EMIT_ARITHCOMPARE (ARITH_EQUAL); - break; - - CASE (Bgtr); - EMIT_ARITHCOMPARE (ARITH_GRTR); - break; - - CASE (Blss); - EMIT_ARITHCOMPARE (ARITH_LESS); - break; - - CASE (Bleq); - EMIT_ARITHCOMPARE (ARITH_LESS_OR_EQUAL); - break; - - CASE (Bgeq); - EMIT_ARITHCOMPARE (ARITH_GRTR_OR_EQUAL); - break; - - CASE (Bdiff); - EMIT_CALL_N_REF ("Fminus", 2); - break; - - CASE (Bnegate); - { - /* (FIXNUMP (TOP) && XFIXNUM (TOP) != MOST_NEGATIVE_FIXNUM - ? make_fixnum (- XFIXNUM (TOP)) - : Fminus (1, &TOP)) */ - - DECL_AND_SAFE_ALLOCA_BLOCK (negate_inline_block, comp.func); - DECL_AND_SAFE_ALLOCA_BLOCK (negate_fcall_block, comp.func); - - gcc_jit_rvalue *tos_as_num = - emit_XFIXNUM (gcc_jit_lvalue_as_rvalue (TOS.gcc_lval)); - - emit_cond_jump ( - gcc_jit_context_new_binary_op ( - comp.ctxt, - NULL, - GCC_JIT_BINARY_OP_LOGICAL_AND, - comp.bool_type, - emit_cast (comp.bool_type, - emit_FIXNUMP (gcc_jit_lvalue_as_rvalue (TOS.gcc_lval))), - gcc_jit_context_new_comparison (comp.ctxt, - NULL, - GCC_JIT_COMPARISON_NE, - tos_as_num, - comp.most_negative_fixnum)), - negate_inline_block, - negate_fcall_block); - - gcc_jit_rvalue *negate_inline_res = - gcc_jit_context_new_unary_op (comp.ctxt, - NULL, - GCC_JIT_UNARY_OP_MINUS, - comp.emacs_int_type, - tos_as_num); - - basic_block_t *bb_orig = comp.block; - - comp.block = negate_inline_block; - emit_assign_to_stack_slot (negate_inline_block, - &TOS, - emit_make_fixnum (negate_inline_res)); - comp.block = negate_fcall_block; - EMIT_CALL_N_REF ("Fminus", 1); - - gcc_jit_block_end_with_jump (negate_inline_block->gcc_bb, - NULL, - bb_map[pc].gcc_bb); - gcc_jit_block_end_with_jump (negate_fcall_block->gcc_bb, - NULL, - bb_map[pc].gcc_bb); - comp.block = bb_orig; - SAFE_FREE (); - } - break; - CASE (Bplus); - EMIT_CALL_N_REF ("Fplus", 2); - break; - CASE (Bmax); - EMIT_CALL_N_REF ("Fmax", 2); - break; - CASE (Bmin); - EMIT_CALL_N_REF ("Fmin", 2); - break; - CASE (Bmult); - EMIT_CALL_N_REF ("Ftimes", 2); - break; - CASE (Bpoint); - args[0] = - gcc_jit_context_new_rvalue_from_int (comp.ctxt, - comp.ptrdiff_type, - PT); - res = emit_call ("make_fixed_natnum", - comp.lisp_obj_type, - 1, - args); - PUSH_RVAL (res); - break; - - CASE_CALL_N (goto_char, 1); - - CASE (Binsert); - EMIT_CALL_N_REF ("Finsert", 1); - break; - - CASE (Bpoint_max); - args[0] = - gcc_jit_context_new_rvalue_from_int (comp.ctxt, - comp.ptrdiff_type, - ZV); - res = emit_call ("make_fixed_natnum", - comp.lisp_obj_type, - 1, - args); - PUSH_RVAL (res); - break; - - CASE (Bpoint_min); - args[0] = - gcc_jit_context_new_rvalue_from_int (comp.ctxt, - comp.ptrdiff_type, - BEGV); - res = emit_call ("make_fixed_natnum", - comp.lisp_obj_type, - 1, - args); - PUSH_RVAL (res); - break; - - CASE_CALL_N (char_after, 1); - CASE_CALL_N (following_char, 0); - - CASE (Bpreceding_char); - res = emit_call ("Fprevious_char", comp.lisp_obj_type, 0, args); - PUSH_RVAL (res); - break; - - CASE_CALL_N (current_column, 0); - - CASE (Bindent_to); - POP1; - args[1] = nil; - res = emit_call ("Findent_to", comp.lisp_obj_type, 2, args); - PUSH_RVAL (res); - break; - - CASE_CALL_N (eolp, 0); - CASE_CALL_N (eobp, 0); - CASE_CALL_N (bolp, 0); - CASE_CALL_N (bobp, 0); - CASE_CALL_N (current_buffer, 0); - CASE_CALL_N (set_buffer, 1); - - CASE (Bsave_current_buffer); /* Obsolete since ??. */ - goto save_current; - CASE (Bsave_current_buffer_1); - save_current: - emit_call ("record_unwind_current_buffer", - comp.void_type, 0, NULL); - break; - - CASE (Binteractive_p); /* Obsolete since 24.1. */ - PUSH_RVAL (emit_lisp_obj_from_ptr (intern ("interactive-p"))); - res = emit_call ("call0", comp.lisp_obj_type, 1, args); - PUSH_RVAL (res); - break; - - CASE_CALL_N (forward_char, 1); - CASE_CALL_N (forward_word, 1); - CASE_CALL_N (skip_chars_forward, 2); - CASE_CALL_N (skip_chars_backward, 2); - CASE_CALL_N (forward_line, 1); - CASE_CALL_N (char_syntax, 1); - CASE_CALL_N (buffer_substring, 2); - CASE_CALL_N (delete_region, 2); - CASE_CALL_N (narrow_to_region, 2); - CASE_CALL_N (widen, 0); - CASE_CALL_N (end_of_line, 1); - - CASE (Bconstant2); - op = FETCH2; - goto do_constant; - - CASE (Bgoto); - op = FETCH2; - gcc_jit_block_end_with_jump (comp.block->gcc_bb, - NULL, - bb_map[op].gcc_bb); - comp.block->terminated = true; - bb_map[op].top = stack; - break; - - CASE (Bgotoifnil); - op = FETCH2; - POP1; - emit_comparison_jump (GCC_JIT_COMPARISON_EQ, args[0], nil, - &bb_map[op], &bb_map[pc]); - bb_map[op].top = stack; - break; - - CASE (Bgotoifnonnil); - op = FETCH2; - POP1; - emit_comparison_jump (GCC_JIT_COMPARISON_NE, args[0], nil, - &bb_map[op], &bb_map[pc]); - bb_map[op].top = stack; - break; - - CASE (Bgotoifnilelsepop); - op = FETCH2; - emit_comparison_jump (GCC_JIT_COMPARISON_EQ, - gcc_jit_lvalue_as_rvalue (TOS.gcc_lval), - nil, - &bb_map[op], &bb_map[pc]); - bb_map[op].top = stack; - DISCARD (1); - break; - - CASE (Bgotoifnonnilelsepop); - op = FETCH2; - emit_comparison_jump (GCC_JIT_COMPARISON_NE, - gcc_jit_lvalue_as_rvalue (TOS.gcc_lval), - nil, - &bb_map[op], &bb_map[pc]); - bb_map[op].top = stack; - DISCARD (1); - break; - - CASE (Breturn); - POP1; - gcc_jit_block_end_with_return(comp.block->gcc_bb, - NULL, - args[0]); - comp.block->terminated = true; - break; - - CASE (Bdiscard); - DISCARD (1); - break; - - CASE (Bdup); - PUSH_LVAL (TOS.gcc_lval); - break; - - CASE (Bsave_excursion); - res = emit_call ("record_unwind_protect_excursion", - comp.void_type, 0, args); - break; - - CASE (Bsave_window_excursion); /* Obsolete since 24.1. */ - EMIT_CALL_N ("helper_save_window_excursion", 1); - break; - - CASE (Bsave_restriction); - args[0] = emit_lisp_obj_from_ptr (save_restriction_restore); - args[1] = emit_call ("save_restriction_save", - comp.lisp_obj_type, - 0, - NULL); - emit_call ("record_unwind_protect", comp.void_ptr_type, 2, args); - break; - - CASE (Bcatch); /* Obsolete since 24.4. */ - POP2; - args[2] = args[1]; - args[1] = emit_lisp_obj_from_ptr (eval_sub); - emit_call ("internal_catch", comp.void_ptr_type, 3, args); - break; - - CASE (Bunwind_protect); /* FIXME: avoid closure for lexbind. */ - POP1; - emit_call ("helper_unwind_protect", comp.void_type, 1, args); - break; - - CASE (Bcondition_case); /* Obsolete since 24.4. */ - POP3; - emit_call ("internal_lisp_condition_case", - comp.lisp_obj_type, 3, args); - break; - - CASE (Btemp_output_buffer_setup); /* Obsolete since 24.1. */ - EMIT_CALL_N ("helper_temp_output_buffer_setup", 1); - break; - - CASE (Btemp_output_buffer_show); /* Obsolete since 24.1. */ - POP2; - emit_call ("temp_output_buffer_show", comp.void_type, 1, - &args[1]); - PUSH_RVAL (args[0]); - emit_call ("helper_unbind_n", comp.lisp_obj_type, 1, args); - - break; - CASE (Bunbind_all); /* Obsolete. Never used. */ - /* To unbind back to the beginning of this frame. Not used yet, - but will be needed for tail-recursion elimination. */ - error ("Bunbind_all not supported"); - break; - - CASE_CALL_N (set_marker, 3); - CASE_CALL_N (match_beginning, 1); - CASE_CALL_N (match_end, 1); - CASE_CALL_N (upcase, 1); - CASE_CALL_N (downcase, 1); - - CASE (Bstringeqlsign); - EMIT_CALL_N ("Fstring_equal", 2); - break; - - CASE (Bstringlss); - EMIT_CALL_N ("Fstring_lessp", 2); - break; - - CASE_CALL_N (equal, 2); - CASE_CALL_N (nthcdr, 2); - CASE_CALL_N (elt, 2); - CASE_CALL_N (member, 2); - CASE_CALL_N (assq, 2); - - case Bsetcar: - POP2; - res = gcc_jit_context_new_call (comp.ctxt, - NULL, - comp.setcar, - 2, args); - PUSH_RVAL (res); - break; - - case Bsetcdr: - POP2; - res = gcc_jit_context_new_call (comp.ctxt, - NULL, - comp.setcdr, - 2, args); - PUSH_RVAL (res); - break; - - CASE (Bcar_safe); - EMIT_CALL_N ("CAR_SAFE", 1); - break; - - CASE (Bcdr_safe); - EMIT_CALL_N ("CDR_SAFE", 1); - break; - - CASE (Bnconc); - EMIT_CALL_N_REF ("Fnconc", 2); - break; - - CASE (Bquo); - EMIT_CALL_N_REF ("Fquo", 2); - break; - - CASE_CALL_N (rem, 2); - - CASE (Bnumberp); - POP1; - res = emit_NUMBERP (args[0]); - res = gcc_jit_context_new_call (comp.ctxt, - NULL, - comp.bool_to_lisp_obj, - 1, &res); - PUSH_RVAL (res); - break; - - CASE (Bintegerp); - POP1; - res = emit_INTEGERP(args[0]); - res = gcc_jit_context_new_call (comp.ctxt, - NULL, - comp.bool_to_lisp_obj, - 1, &res); - PUSH_RVAL (res); - break; - - CASE (BRgoto); - op = FETCH - 128; - op += pc; - gcc_jit_block_end_with_jump (comp.block->gcc_bb, - NULL, - bb_map[op].gcc_bb); - comp.block->terminated = true; - bb_map[op].top = stack; - break; - - CASE (BRgotoifnil); - op = FETCH - 128; - op += pc; - POP1; - emit_comparison_jump (GCC_JIT_COMPARISON_EQ, args[0], nil, - &bb_map[op], &bb_map[pc]); - bb_map[op].top = stack; - break; - - CASE (BRgotoifnonnil); - op = FETCH - 128; - op += pc; - POP1; - emit_comparison_jump (GCC_JIT_COMPARISON_NE, args[0], nil, - &bb_map[op], &bb_map[pc]); - bb_map[op].top = stack; - break; - - CASE (BRgotoifnilelsepop); - op = FETCH - 128; - op += pc; - emit_comparison_jump (GCC_JIT_COMPARISON_EQ, - gcc_jit_lvalue_as_rvalue (TOS.gcc_lval), - nil, - &bb_map[op], &bb_map[pc]); - bb_map[op].top = stack; - DISCARD (1); - break; - - CASE (BRgotoifnonnilelsepop); - op = FETCH - 128; - op += pc; - emit_comparison_jump (GCC_JIT_COMPARISON_NE, - gcc_jit_lvalue_as_rvalue (TOS.gcc_lval), - nil, - &bb_map[op], &bb_map[pc]); - bb_map[op].top = stack; - DISCARD (1); - break; - - CASE (BinsertN); - op = FETCH; - EMIT_CALL_N_REF ("Finsert", op); - break; - - CASE (Bstack_set); - /* stack-set-0 = discard; stack-set-1 = discard-1-preserve-tos. */ - op = FETCH; - POP1; - if (op > 0) - emit_assign_to_stack_slot (comp.block, stack - op, args[0]); - break; - - CASE (Bstack_set2); - op = FETCH2; - POP1; - emit_assign_to_stack_slot (comp.block, stack - op, args[0]); - break; - - CASE (BdiscardN); - op = FETCH; - if (op & 0x80) - { - op &= 0x7F; - POP1; - emit_assign_to_stack_slot (comp.block, stack - op - 1, args[0]); - } - - DISCARD (op); - break; - CASE (Bswitch); - /* The cases of Bswitch that we handle (which in theory is - all of them) are done in Bconstant, below. This is done - due to a design issue with Bswitch -- it should have - taken a constant pool index inline, but instead looks for - a constant on the stack. */ - goto fail; - break; - - default: - CASE (Bconstant); - { - if (op < Bconstant || op > Bconstant + const_length) - goto fail; - - op -= Bconstant; - do_constant: - - /* See the Bswitch case for commentary. */ - if (pc >= bytestr_length || bytestr_data[pc] != Bswitch) - { - gcc_jit_rvalue *c = - emit_lisp_obj_from_ptr (vectorp[op]); - PUSH_RVAL (c); - TOS.type = XTYPE (vectorp[op]); - if (TOS.type == Lisp_Symbol) - { - /* Store the symbol value for later use is used while - optimizing native and self calls. */ - TOS.constant = vectorp[op]; - TOS.const_set = true; - } - break; - } - - /* Jump table with following Bswitch. */ - ++pc; - - struct Lisp_Hash_Table *h = XHASH_TABLE (vectorp[op]); - POP1; - basic_block_t *jump_block; - for (ptrdiff_t i = 0; i < HASH_TABLE_SIZE (h); ++i) - if (!NILP (HASH_HASH (h, i))) - { - SAFE_ALLOCA_BLOCK (jump_block, - comp.func, - format_string ("jump_t_%ld", - i)); - ptrdiff_t target_pc = XFIXNUM (HASH_VALUE (h, i)); - gcc_jit_rvalue *val = - emit_lisp_obj_from_ptr (HASH_KEY (h, i)); - emit_cond_jump (emit_EQ (args[0], val), &bb_map[target_pc], - jump_block); - comp.block = jump_block; - } - - break; - } - } - } - - if (COMP_DEBUG) - gcc_jit_context_dump_to_file (comp.ctxt, "gcc-ctxt-dump.c", 1); - comp_res.gcc_res = gcc_jit_context_compile(comp.ctxt); - - goto exit; - - fail: - error ("Something went wrong"); - - exit: - xfree (bb_map); - SAFE_FREE (); - return comp_res; + return Qt; } -void -emacs_native_compile (const char *lisp_f_name, const char *c_f_name, - Lisp_Object func, int opt_level, bool dump_asm) +DEFUN ("comp-add-func-to-ctxt", Fcomp_add_func_to_ctxt, Scomp_add_func_to_ctxt, + 1, 1, 0, + doc: /* Add limple FUNC to the current compilation context. */) + (Lisp_Object func) { - init_comp (opt_level); - Lisp_Object bytestr = AREF (func, COMPILED_BYTECODE); - CHECK_STRING (bytestr); - - if (STRING_MULTIBYTE (bytestr)) - /* BYTESTR must have been produced by Emacs 20.2 or the earlier - because they produced a raw 8-bit string for byte-code and now - such a byte-code string is loaded as multibyte while raw 8-bit - characters converted to multibyte form. Thus, now we must - convert them back to the originally intended unibyte form. */ - bytestr = Fstring_as_unibyte (bytestr); - - ptrdiff_t bytestr_length = SBYTES (bytestr); - - Lisp_Object vector = AREF (func, COMPILED_CONSTANTS); - CHECK_VECTOR (vector); - Lisp_Object *vectorp = XVECTOR (vector)->contents; - - Lisp_Object maxdepth = AREF (func, COMPILED_STACK_DEPTH); - CHECK_FIXNAT (maxdepth); - - /* Gcc doesn't like being interrupted. */ - sigset_t oldset; - block_atimers (&oldset); - - comp_f_res_t comp_res = compile_f (lisp_f_name, c_f_name, bytestr_length, - SDATA (bytestr), XFIXNAT (maxdepth) + 1, - vectorp, ASIZE (vector), - AREF (func, COMPILED_ARGLIST)); - - union Aligned_Lisp_Subr *x = xmalloc (sizeof (union Aligned_Lisp_Subr)); - - x->s.header.size = PVEC_SUBR << PSEUDOVECTOR_AREA_BITS; - x->s.function.a0 = gcc_jit_result_get_code(comp_res.gcc_res, c_f_name); - eassert (x->s.function.a0); - x->s.min_args = comp_res.min_args; - x->s.max_args = comp_res.max_args; - x->s.symbol_name = lisp_f_name; - defsubr(x); - - if (dump_asm) - { - gcc_jit_context_compile_to_file (comp.ctxt, - GCC_JIT_OUTPUT_KIND_ASSEMBLER, - DISASS_FILE_NAME); - } - unblock_atimers (&oldset); - release_comp (); + return Qt; } -DEFUN ("native-compile", Fnative_compile, Snative_compile, - 1, 3, 0, - doc: /* Compile as native code function FUNC and load it. */) /* FIXME doc */ - (Lisp_Object func, Lisp_Object speed, Lisp_Object disassemble) +DEFUN ("comp-compile-ctxt", Fcomp_compile_ctxt, Scomp_compile_ctxt, + 0, 1, 0, + doc: /* Compile as native code the current context. */) + (Lisp_Object disassemble) { - static char c_f_name[MAX_FUN_NAME]; - char *lisp_f_name; - - if (!SYMBOLP (func)) - error ("Not a symbol."); - - lisp_f_name = (char *) SDATA (SYMBOL_NAME (func)); - - int res = snprintf (c_f_name, MAX_FUN_NAME, "Fnative_comp_%s", lisp_f_name); - - if (res >= MAX_FUN_NAME) - error ("Function name too long"); - - /* FIXME how many other characters are not allowed in C? - This will introduce name clashs too. */ - char *c = c_f_name; - while (*c) - { - if (*c == '-' || - *c == '+') - *c = '_'; - ++c; - } - - func = indirect_function (func); - if (!COMPILEDP (func)) - error ("Not a byte-compiled function"); - - if (speed != Qnil && - (!FIXNUMP (speed) || - !(XFIXNUM (speed) >= 0 && - XFIXNUM (speed) <= 3))) - error ("opt-level must be number between 0 and 3"); - - int opt_level; - if (speed == Qnil) - opt_level = DEFAULT_SPEED; - else - opt_level = XFIXNUM (speed); - - emacs_native_compile (lisp_f_name, c_f_name, func, opt_level, - !NILP (disassemble)); - - if (!NILP (disassemble)) - { - FILE *fd; - Lisp_Object str; - - if ((fd = fopen (DISASS_FILE_NAME, "r"))) - { - fseek (fd , 0L, SEEK_END); - long int size = ftell (fd); - fseek (fd , 0L, SEEK_SET); - char *buffer = xmalloc (size + 1); - ptrdiff_t nread = fread (buffer, 1, size, fd); - if (nread > 0) - { - size = nread; - buffer[size] = '\0'; - str = make_string (buffer, size); - fclose (fd); - } - else - str = empty_unibyte_string; - xfree (buffer); - return str; - } - else - { - error ("disassemble file could not be found"); - } - } - - return Qnil; + gcc_jit_context_set_int_option (comp.ctxt, + GCC_JIT_INT_OPTION_OPTIMIZATION_LEVEL, + comp_speed); + return Qt; } void syms_of_comp (void) { - defsubr (&Snative_compile); + defsubr (&Scomp_init_ctxt); + defsubr (&Scomp_release_ctxt); + defsubr (&Scomp_add_func_to_ctxt); + defsubr (&Scomp_compile_ctxt); comp.func_hash = Qnil; staticpro (&comp.func_hash); + + DEFVAR_INT ("comp-speed", comp_speed, + doc: /* From 0 to 3. */); + comp_speed = DEFAULT_SPEED; + } /******************************************************************************/ diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 421f77008a..c6ee5b7685 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -103,6 +103,11 @@ (defun comp-tests-varset-f () (setq comp-tests-var1 55)) (comp-test-compile #'comp-tests-varset-f) +((byte-constant 55 . 1) + (byte-dup . 0) + (byte-varset comp-tests-var1 . 0) + (byte-return . 0)) + (comp-tests-varset-f) (should (= comp-tests-var1 55))) commit e209967089ebd7fa91ab7268dc0fe66e1d1297be Author: Andrea Corallo Date: Mon Jul 8 09:29:13 2019 +0200 working on diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index e3594227e2..22dcfc77b3 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -77,11 +77,6 @@ (type nil :documentation "When non nil is used for type propagation")) -(cl-defun make-comp-mvar (func &key slot const-vld constant type) - (make--comp-mvar :n (cl-incf (comp-func-limple-cnt func)) - :slot slot :const-vld const-vld :constant constant - :type type)) - (cl-defstruct (comp-limple-frame (:copier nil)) "A LIMPLE func." (sp 0 :type 'fixnum @@ -119,6 +114,11 @@ (defvar comp-limple) (defvar comp-func) +(cl-defun make-comp-mvar (&key slot const-vld constant type) + (make--comp-mvar :n (cl-incf (comp-func-limple-cnt comp-func)) + :slot slot :const-vld const-vld :constant constant + :type type)) + (defmacro comp-sp () "Current stack pointer." '(comp-limple-frame-sp comp-frame)) @@ -139,8 +139,7 @@ "Push call X into frame." (cl-incf (comp-sp)) (setf (comp-slot) - (make-comp-mvar comp-func - :slot (comp-sp) + (make-comp-mvar :slot (comp-sp) :type (alist-get (second src-slot) comp-known-ret-types))) (push (list '=call (comp-slot) src-slot) comp-limple)) @@ -158,8 +157,7 @@ "Push VAL into frame. VAL is known at compile time." (cl-incf (comp-sp)) - (setf (comp-slot) (make-comp-mvar comp-func - :slot (comp-sp) + (setf (comp-slot) (make-comp-mvar :slot (comp-sp) :const-vld t :constant val)) (push (list '=const (comp-slot) val) comp-limple)) @@ -169,8 +167,11 @@ VAL is known at compile time." (cl-decf (comp-sp) n)) (defun comp-limplify-listn (n) + "Limplify list N." (comp-pop 1) - (comp-push-call `(call Fcons ,(comp-slot-next) nil)) + (comp-push-call `(call Fcons ,(comp-slot-next) + ,(make-comp-mvar :const-vld t + :constant nil))) (dotimes (_ (1- n)) (comp-pop 2) (comp-push-call `(call Fcons @@ -178,8 +179,7 @@ VAL is known at compile time." ,(comp-slot-n (+ 2 (comp-sp))))))) (defun comp-limplify-lap-inst (inst) - "Limplify LAP instruction INST in current frame accumulating in `comp-limple' - for current `func'." + "Limplify LAP instruction INST accumulating in `comp-limple'." (let ((op (car inst))) (pcase op ('byte-dup @@ -199,6 +199,12 @@ VAL is known at compile time." ('byte-cdr (comp-pop 1) (comp-push-call `(call Fcdr ,(comp-sp)))) + ('byte-car-safe + (comp-pop 1) + (comp-push-call `(call Fcar-safe ,(comp-sp)))) + ('byte-cdr-safe + (comp-pop 1) + (comp-push-call `(call Fcdr-safe ,(comp-sp)))) ('byte-list1 (comp-limplify-listn 1)) ('byte-list2 @@ -214,14 +220,13 @@ VAL is known at compile time." (defun comp-limplify (func) "Given FUNC and return LIMPLE." (let* ((frame-size (aref (comp-func-byte-func func) 3)) + (comp-func func) (comp-frame (make-comp-limple-frame :sp -1 :frame (let ((v (make-vector frame-size nil))) (cl-loop for i below frame-size - do (aset v i (make-comp-mvar func - :slot i))) + do (aset v i (make-comp-mvar :slot i))) v))) - (comp-func func) (comp-limple ())) ;; Prologue (push '(BLOCK prologue) comp-limple) commit f745b498ad42fd6289870fabc7e8e28b46e14b07 Author: Andrea Corallo Date: Mon Jul 8 09:15:09 2019 +0200 move out comp-limplify-listn diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 8740779b8b..e3594227e2 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -168,47 +168,48 @@ VAL is known at compile time." "Pop N elements from the meta-stack." (cl-decf (comp-sp) n)) +(defun comp-limplify-listn (n) + (comp-pop 1) + (comp-push-call `(call Fcons ,(comp-slot-next) nil)) + (dotimes (_ (1- n)) + (comp-pop 2) + (comp-push-call `(call Fcons + ,(comp-slot-next) + ,(comp-slot-n (+ 2 (comp-sp))))))) + (defun comp-limplify-lap-inst (inst) "Limplify LAP instruction INST in current frame accumulating in `comp-limple' for current `func'." - (cl-flet ((do-list (n) - (comp-pop 1) - (comp-push-call `(call Fcons ,(comp-slot-next) nil)) - (dotimes (_ (1- n)) - (comp-pop 2) - (comp-push-call `(call Fcons - ,(comp-slot-next) - ,(comp-slot-n (+ 2 (comp-sp)))))))) - (let ((op (car inst))) - (pcase op - ('byte-dup - (comp-push-slot-n (comp-sp))) - ('byte-varref - (comp-push-call `(call Fsymbol_value ,(second inst)))) - ('byte-constant - (comp-push-const (second inst))) - ('byte-stack-ref - (comp-push-slot-n (- (comp-sp) (cdr inst)))) - ('byte-plus - (comp-pop 2) - (comp-push-call `(callref Fplus 2 ,(comp-sp)))) - ('byte-car - (comp-pop 1) - (comp-push-call `(call Fcar ,(comp-sp)))) - ('byte-cdr - (comp-pop 1) - (comp-push-call `(call Fcdr ,(comp-sp)))) - ('byte-list1 - (do-list 1)) - ('byte-list2 - (do-list 2)) - ('byte-list3 - (do-list 3)) - ('byte-list4 - (do-list 4)) - ('byte-return - `(return ,(comp-slot))) - (_ (error "Unexpected LAP op %s" (symbol-name op))))))) + (let ((op (car inst))) + (pcase op + ('byte-dup + (comp-push-slot-n (comp-sp))) + ('byte-varref + (comp-push-call `(call Fsymbol_value ,(second inst)))) + ('byte-constant + (comp-push-const (second inst))) + ('byte-stack-ref + (comp-push-slot-n (- (comp-sp) (cdr inst)))) + ('byte-plus + (comp-pop 2) + (comp-push-call `(callref Fplus 2 ,(comp-sp)))) + ('byte-car + (comp-pop 1) + (comp-push-call `(call Fcar ,(comp-sp)))) + ('byte-cdr + (comp-pop 1) + (comp-push-call `(call Fcdr ,(comp-sp)))) + ('byte-list1 + (comp-limplify-listn 1)) + ('byte-list2 + (comp-limplify-listn 2)) + ('byte-list3 + (comp-limplify-listn 3)) + ('byte-list4 + (comp-limplify-listn 4)) + ('byte-return + `(return ,(comp-slot))) + (_ (error "Unexpected LAP op %s" (symbol-name op)))))) (defun comp-limplify (func) "Given FUNC and return LIMPLE." commit a4ea174a3727b9d690a4503f1f32b0382088f419 Author: Andrea Corallo Date: Mon Jul 8 09:06:58 2019 +0200 clean all crazy macrology in favor of some special var diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index a51b993c65..8740779b8b 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -114,13 +114,18 @@ ;; (cl-every #'identity (mapcar #'comp-mvar-const-vld args))) ;; (apply f (mapcar #'comp-mvar-constant args))))) +;; Special vars used during limplifications +(defvar comp-frame) +(defvar comp-limple) +(defvar comp-func) + (defmacro comp-sp () "Current stack pointer." - '(comp-limple-frame-sp frame)) + '(comp-limple-frame-sp comp-frame)) (defmacro comp-slot-n (n) "Slot N into the meta-stack." - `(aref (comp-limple-frame-frame frame) ,n)) + `(aref (comp-limple-frame-frame comp-frame) ,n)) (defmacro comp-slot () "Current slot into the meta-stack pointed by sp." @@ -130,44 +135,42 @@ "Slot into the meta-stack pointed by sp + 1." '(comp-slot-n (1+ (comp-sp)))) -(defmacro comp-push-call (x) +(defun comp-push-call (src-slot) "Push call X into frame." - `(let ((src-slot ,x)) - (cl-incf (comp-sp)) - (setf (comp-slot) - (make-comp-mvar func - :slot (comp-sp) - :type (alist-get (second src-slot) - comp-known-ret-types))) - (push (list '=call (comp-slot) src-slot) ir))) - -(defmacro comp-push-slot-n (n) + (cl-incf (comp-sp)) + (setf (comp-slot) + (make-comp-mvar comp-func + :slot (comp-sp) + :type (alist-get (second src-slot) + comp-known-ret-types))) + (push (list '=call (comp-slot) src-slot) comp-limple)) + +(defun comp-push-slot-n (n) "Push slot number N into frame." - `(let ((src-slot (comp-slot-n ,n))) - (cl-incf (comp-sp)) - (setf (comp-slot) - (copy-sequence src-slot)) - (setf (comp-mvar-slot (comp-slot)) (comp-sp)) - (push (list '=slot (comp-slot) src-slot) ir))) - -(defmacro comp-push-const (x) - "Push X into frame. -X value is known at compile time." - `(let ((val ,x)) - (cl-incf (comp-sp)) - (setf (comp-slot) (make-comp-mvar func - :slot (comp-sp) - :const-vld t - :constant val)) - (push (list '=const (comp-slot) val) ir))) - -(defmacro comp-pop (n) + (let ((src-slot (comp-slot-n n))) + (cl-incf (comp-sp)) + (setf (comp-slot) + (copy-sequence src-slot)) + (setf (comp-mvar-slot (comp-slot)) (comp-sp)) + (push (list '=slot (comp-slot) src-slot) comp-limple))) + +(defun comp-push-const (val) + "Push VAL into frame. +VAL is known at compile time." + (cl-incf (comp-sp)) + (setf (comp-slot) (make-comp-mvar comp-func + :slot (comp-sp) + :const-vld t + :constant val)) + (push (list '=const (comp-slot) val) comp-limple)) + +(defun comp-pop (n) "Pop N elements from the meta-stack." - `(cl-decf (comp-sp) ,n)) + (cl-decf (comp-sp) n)) -(defun comp-limplify-lap-inst (inst frame ir func) - "Limplify LAP instruction INST in current FRAME accumulating in IR for current - FUNC." +(defun comp-limplify-lap-inst (inst) + "Limplify LAP instruction INST in current frame accumulating in `comp-limple' + for current `func'." (cl-flet ((do-list (n) (comp-pop 1) (comp-push-call `(call Fcons ,(comp-slot-next) nil)) @@ -205,28 +208,29 @@ X value is known at compile time." (do-list 4)) ('byte-return `(return ,(comp-slot))) - (_ (error "Unexpected LAP op %s" (symbol-name op)))))) - ir) + (_ (error "Unexpected LAP op %s" (symbol-name op))))))) (defun comp-limplify (func) "Given FUNC and return LIMPLE." (let* ((frame-size (aref (comp-func-byte-func func) 3)) - (frame (make-comp-limple-frame - :sp -1 - :frame (make-vector frame-size nil))) - (limple-ir ())) + (comp-frame (make-comp-limple-frame + :sp -1 + :frame (let ((v (make-vector frame-size nil))) + (cl-loop for i below frame-size + do (aset v i (make-comp-mvar func + :slot i))) + v))) + (comp-func func) + (comp-limple ())) ;; Prologue - (push '(BLOCK prologue) limple-ir) + (push '(BLOCK prologue) comp-limple) (cl-loop for i below (comp-args-mandatory (comp-func-args func)) do (progn (cl-incf (comp-sp)) - (push `(=par ,(comp-slot) ,i) limple-ir))) - (push '(BLOCK body) limple-ir) - (mapc (lambda (inst) - (setq limple-ir (comp-limplify-lap-inst inst frame limple-ir func))) - (comp-func-ir func)) - (setq limple-ir (reverse limple-ir)) - (setf (comp-func-ir func) limple-ir) + (push `(=par ,(comp-slot) ,i) comp-limple))) + (push '(BLOCK body) comp-limple) + (mapc #'comp-limplify-lap-inst (comp-func-ir func)) + (setf (comp-func-ir func) (reverse comp-limple)) (when comp-debug (cl-prettyprint (comp-func-ir func))) func)) commit 8107fc6d0ce15f7a3da13df9eb74d63ab00167a7 Author: Andrea Corallo Date: Mon Jul 8 07:56:37 2019 +0200 add SSA diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 8ed75e0a4b..a51b993c65 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -59,10 +59,14 @@ :documentation "Byte compiled version") (ir nil :documentation "Current intermediate rappresentation") - (args nil :type 'comp-args)) + (args nil :type 'comp-args) + (limple-cnt -1 :type 'number + :documentation "Counter to create ssa limple vars")) -(cl-defstruct (comp-mvar (:copier nil)) +(cl-defstruct (comp-mvar (:copier nil) (:constructor make--comp-mvar)) "A meta-variable being a slot in the meta-stack." + (n nil :type number + :documentation "SSA number") (slot nil :type fixnum :documentation "Slot position") (const-vld nil @@ -73,6 +77,11 @@ (type nil :documentation "When non nil is used for type propagation")) +(cl-defun make-comp-mvar (func &key slot const-vld constant type) + (make--comp-mvar :n (cl-incf (comp-func-limple-cnt func)) + :slot slot :const-vld const-vld :constant constant + :type type)) + (cl-defstruct (comp-limple-frame (:copier nil)) "A LIMPLE func." (sp 0 :type 'fixnum @@ -86,17 +95,24 @@ :mandatory (logand x 127) :nonrest (ash x -8))) -(defun comp-recuparate-lap (ir) - "Byte compile and recuparate LAP rapresentation for IR." +(defun comp-recuparate-lap (func) + "Byte compile and recuparate LAP rapresentation for FUNC." ;; FIXME block timers here, otherwise we could spill the wrong LAP. - (setf (comp-func-byte-func ir) - (byte-compile (comp-func-symbol-name ir))) + (setf (comp-func-byte-func func) + (byte-compile (comp-func-symbol-name func))) (when comp-debug (cl-prettyprint byte-compile-lap-output)) - (setf (comp-func-args ir) - (comp-decrypt-lambda-list (aref (comp-func-byte-func ir) 0))) - (setf (comp-func-ir ir) byte-compile-lap-output) - ir) + (setf (comp-func-args func) + (comp-decrypt-lambda-list (aref (comp-func-byte-func func) 0))) + (setf (comp-func-ir func) byte-compile-lap-output) + func) + +;; (defun comp-opt-call (inst) +;; "Optimize if possible a side-effect-free call in INST." +;; (cl-destructuring-bind (_ f &rest args) inst +;; (when (and (member f comp-mostly-pure-funcs) +;; (cl-every #'identity (mapcar #'comp-mvar-const-vld args))) +;; (apply f (mapcar #'comp-mvar-constant args))))) (defmacro comp-sp () "Current stack pointer." @@ -114,19 +130,13 @@ "Slot into the meta-stack pointed by sp + 1." '(comp-slot-n (1+ (comp-sp)))) -;; (defun comp-opt-call (inst) -;; "Optimize if possible a side-effect-free call in INST." -;; (cl-destructuring-bind (_ f &rest args) inst -;; (when (and (member f comp-mostly-pure-funcs) -;; (cl-every #'identity (mapcar #'comp-mvar-const-vld args))) -;; (apply f (mapcar #'comp-mvar-constant args))))) - (defmacro comp-push-call (x) "Push call X into frame." `(let ((src-slot ,x)) (cl-incf (comp-sp)) (setf (comp-slot) - (make-comp-mvar :slot (comp-sp) + (make-comp-mvar func + :slot (comp-sp) :type (alist-get (second src-slot) comp-known-ret-types))) (push (list '=call (comp-slot) src-slot) ir))) @@ -145,7 +155,8 @@ X value is known at compile time." `(let ((val ,x)) (cl-incf (comp-sp)) - (setf (comp-slot) (make-comp-mvar :slot (comp-sp) + (setf (comp-slot) (make-comp-mvar func + :slot (comp-sp) :const-vld t :constant val)) (push (list '=const (comp-slot) val) ir))) @@ -154,9 +165,9 @@ X value is known at compile time." "Pop N elements from the meta-stack." `(cl-decf (comp-sp) ,n)) -(defun comp-limplify-lap-inst (inst frame ir) - "Limplify LAP instruction INST in current FRAME accumulating in IR. -Return the new head." +(defun comp-limplify-lap-inst (inst frame ir func) + "Limplify LAP instruction INST in current FRAME accumulating in IR for current + FUNC." (cl-flet ((do-list (n) (comp-pop 1) (comp-push-call `(call Fcons ,(comp-slot-next) nil)) @@ -197,31 +208,28 @@ Return the new head." (_ (error "Unexpected LAP op %s" (symbol-name op)))))) ir) -(defun comp-limplify (ir) - "Given IR and return LIMPLE." - (let* ((frame-size (aref (comp-func-byte-func ir) 3)) +(defun comp-limplify (func) + "Given FUNC and return LIMPLE." + (let* ((frame-size (aref (comp-func-byte-func func) 3)) (frame (make-comp-limple-frame :sp -1 - :frame (let ((v (make-vector frame-size nil))) - (cl-loop for i below frame-size - do (aset v i (make-comp-mvar :slot i))) - v))) + :frame (make-vector frame-size nil))) (limple-ir ())) ;; Prologue (push '(BLOCK prologue) limple-ir) - (cl-loop for i below (comp-args-mandatory (comp-func-args ir)) + (cl-loop for i below (comp-args-mandatory (comp-func-args func)) do (progn (cl-incf (comp-sp)) (push `(=par ,(comp-slot) ,i) limple-ir))) (push '(BLOCK body) limple-ir) (mapc (lambda (inst) - (setq limple-ir (comp-limplify-lap-inst inst frame limple-ir))) - (comp-func-ir ir)) + (setq limple-ir (comp-limplify-lap-inst inst frame limple-ir func))) + (comp-func-ir func)) (setq limple-ir (reverse limple-ir)) - (setf (comp-func-ir ir) limple-ir) + (setf (comp-func-ir func) limple-ir) (when comp-debug - (cl-prettyprint (comp-func-ir ir))) - ir)) + (cl-prettyprint (comp-func-ir func))) + func)) (defun native-compile (fun) "FUN is the function definition to be compiled to native code." @@ -231,11 +239,11 @@ Return the new head." (progn (when (byte-code-function-p f) (error "Can't native compile an already bytecompiled function")) - (cl-loop with ir = (make-comp-func :symbol-name fun - :func f) + (cl-loop with func = (make-comp-func :symbol-name fun + :func f) for pass in comp-passes - do (funcall pass ir) - finally return ir)) + do (funcall pass func) + finally return func)) (error "Trying to native compile not a function"))) (provide 'comp) diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index b6a8904347..421f77008a 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -31,13 +31,16 @@ (defvar comp-tests-var1 3) +(defun comp-test-compile (f) + ;; (byte-compile f) + (native-compile f)) + (ert-deftest comp-tests-varref () "Testing varref." (defun comp-tests-varref-f () comp-tests-var1) - (byte-compile #'comp-tests-varref-f) - (native-compile #'comp-tests-varref-f) + (comp-test-compile #'comp-tests-varref-f) (should (= (comp-tests-varref-f) 3))) @@ -58,16 +61,11 @@ ;; Bcdr_safe (cdr-safe x)) - (byte-compile #'comp-tests-list-f) - (native-compile #'comp-tests-list-f) - (byte-compile #'comp-tests-car-f) - (native-compile #'comp-tests-car-f) - (byte-compile #'comp-tests-cdr-f) - (native-compile #'comp-tests-cdr-f) - (byte-compile #'comp-tests-car-safe-f) - (native-compile #'comp-tests-car-safe-f) - (byte-compile #'comp-tests-cdr-safe-f) - (native-compile #'comp-tests-cdr-safe-f) + (comp-test-compile #'comp-tests-list-f) + (comp-test-compile #'comp-tests-car-f) + (comp-test-compile #'comp-tests-cdr-f) + (comp-test-compile #'comp-tests-car-safe-f) + (comp-test-compile #'comp-tests-cdr-safe-f) (should (equal (comp-tests-list-f) '(1 2 3))) (should (= (comp-tests-car-f '(1 . 2)) 1)) @@ -91,13 +89,11 @@ "Testing cons car cdr." (defun comp-tests-cons-car-f () (car (cons 1 2))) - (byte-compile #'comp-tests-cons-car-f) - (native-compile #'comp-tests-cons-car-f) + (comp-test-compile #'comp-tests-cons-car-f) (defun comp-tests-cons-cdr-f (x) (cdr (cons 'foo x))) - (byte-compile #'comp-tests-cons-cdr-f) - (native-compile #'comp-tests-cons-cdr-f) + (comp-test-compile #'comp-tests-cons-cdr-f) (should (= (comp-tests-cons-car-f) 1)) (should (= (comp-tests-cons-cdr-f 3) 3))) @@ -106,8 +102,7 @@ "Testing varset." (defun comp-tests-varset-f () (setq comp-tests-var1 55)) - (byte-compile #'comp-tests-varset-f) - (native-compile #'comp-tests-varset-f) + (comp-test-compile #'comp-tests-varset-f) (comp-tests-varset-f) (should (= comp-tests-var1 55))) @@ -116,8 +111,7 @@ "Testing length." (defun comp-tests-length-f () (length '(1 2 3))) - (byte-compile #'comp-tests-length-f) - (native-compile #'comp-tests-length-f) + (comp-test-compile #'comp-tests-length-f) (should (= (comp-tests-length-f) 3))) @@ -127,8 +121,7 @@ (let ((vec [1 2 3])) (aset vec 2 100) (aref vec 2))) - (byte-compile #'comp-tests-aref-aset-f) - (native-compile #'comp-tests-aref-aset-f) + (comp-test-compile #'comp-tests-aref-aset-f) (should (= (comp-tests-aref-aset-f) 100))) @@ -137,8 +130,7 @@ (defvar comp-tests-var2 3) (defun comp-tests-symbol-value-f () (symbol-value 'comp-tests-var2)) - (byte-compile #'comp-tests-symbol-value-f) - (native-compile #'comp-tests-symbol-value-f) + (comp-test-compile #'comp-tests-symbol-value-f) (should (= (comp-tests-symbol-value-f) 3))) @@ -147,8 +139,7 @@ (defun comp-tests-concat-f (x) (concat "a" "b" "c" "d" (concat "a" "b" "c" (concat "a" "b" (concat "foo" x))))) - (byte-compile #'comp-tests-concat-f) - (native-compile #'comp-tests-concat-f) + (comp-test-compile #'comp-tests-concat-f) (should (string= (comp-tests-concat-f "bar") "abcdabcabfoobar"))) @@ -159,15 +150,13 @@ (defun comp-tests-ffuncall-caller-f () (comp-tests-ffuncall-callee-f 1 2 3)) - (byte-compile #'comp-tests-ffuncall-caller-f) - (native-compile #'comp-tests-ffuncall-caller-f) + (comp-test-compile #'comp-tests-ffuncall-caller-f) (should (equal (comp-tests-ffuncall-caller-f) '(1 2 3))) (defun comp-tests-ffuncall-callee-optional-f (a b &optional c d) (list a b c d)) - (byte-compile #'comp-tests-ffuncall-callee-optional-f) - (native-compile #'comp-tests-ffuncall-callee-optional-f) + (comp-test-compile #'comp-tests-ffuncall-callee-optional-f) (should (equal (comp-tests-ffuncall-callee-optional-f 1 2 3 4) '(1 2 3 4))) (should (equal (comp-tests-ffuncall-callee-optional-f 1 2 3) '(1 2 3 nil))) @@ -175,8 +164,7 @@ (defun comp-tests-ffuncall-callee-rest-f (a b &rest c) (list a b c)) - (byte-compile #'comp-tests-ffuncall-callee-rest-f) - (native-compile #'comp-tests-ffuncall-callee-rest-f) + (comp-test-compile #'comp-tests-ffuncall-callee-rest-f) (should (equal (comp-tests-ffuncall-callee-rest-f 1 2) '(1 2 nil))) (should (equal (comp-tests-ffuncall-callee-rest-f 1 2 3) '(1 2 (3)))) @@ -186,8 +174,7 @@ "Call a primitive with no dedicate op." (make-vector 1 nil)) - (byte-compile #'comp-tests-ffuncall-native-f) - (native-compile #'comp-tests-ffuncall-native-f) + (comp-test-compile #'comp-tests-ffuncall-native-f) (should (equal (comp-tests-ffuncall-native-f) [nil])) @@ -195,16 +182,14 @@ "Call a primitive with no dedicate op with &rest." (vector 1 2 3)) - (byte-compile #'comp-tests-ffuncall-native-rest-f) - (native-compile #'comp-tests-ffuncall-native-rest-f) + (comp-test-compile #'comp-tests-ffuncall-native-rest-f) (should (equal (comp-tests-ffuncall-native-rest-f) [1 2 3])) (defun comp-tests-ffuncall-apply-many-f (x) (apply #'list x)) - (byte-compile #'comp-tests-ffuncall-apply-many-f) - (native-compile #'comp-tests-ffuncall-apply-many-f) + (comp-test-compile #'comp-tests-ffuncall-apply-many-f) (should (equal (comp-tests-ffuncall-apply-many-f '(1 2 3)) '(1 2 3))) @@ -213,8 +198,7 @@ (1+ x)))) (funcall fun x))) - (byte-compile #'comp-tests-ffuncall-lambda-f) - (native-compile #'comp-tests-ffuncall-lambda-f) + (comp-test-compile #'comp-tests-ffuncall-lambda-f) (should (= (comp-tests-ffuncall-lambda-f 1) 2))) @@ -226,8 +210,6 @@ ('y 'b) (_ 'c))) - (byte-compile #'comp-tests-jump-table-1-f) - (byte-compile #'comp-tests-jump-table-1-f) (should (eq (comp-tests-jump-table-1-f 'x) 'a)) (should (eq (comp-tests-jump-table-1-f 'y) 'b)) @@ -242,10 +224,8 @@ ;; Generate goto-if-nil-else-pop (when x 1340)) - (byte-compile #'comp-tests-conditionals-1-f) - (byte-compile #'comp-tests-conditionals-2-f) - (native-compile #'comp-tests-conditionals-1-f) - (native-compile #'comp-tests-conditionals-2-f) + (comp-test-compile #'comp-tests-conditionals-1-f) + (comp-test-compile #'comp-tests-conditionals-2-f) (should (= (comp-tests-conditionals-1-f t) 1)) (should (= (comp-tests-conditionals-1-f nil) 2)) @@ -264,12 +244,9 @@ ;; Bnegate (- x)) - (byte-compile #'comp-tests-fixnum-1-minus-f) - (byte-compile #'comp-tests-fixnum-1-plus-f) - (byte-compile #'comp-tests-fixnum-minus-f) - (native-compile #'comp-tests-fixnum-1-minus-f) - (native-compile #'comp-tests-fixnum-1-plus-f) - (native-compile #'comp-tests-fixnum-minus-f) + (comp-test-compile #'comp-tests-fixnum-1-minus-f) + (comp-test-compile #'comp-tests-fixnum-1-plus-f) + (comp-test-compile #'comp-tests-fixnum-minus-f) (should (= (comp-tests-fixnum-1-minus-f 10) 9)) (should (= (comp-tests-fixnum-1-minus-f most-negative-fixnum) @@ -311,17 +288,12 @@ ;; Bgeq (>= x y)) - (byte-compile #'comp-tests-eqlsign-f) - (byte-compile #'comp-tests-gtr-f) - (byte-compile #'comp-tests-lss-f) - (byte-compile #'comp-tests-les-f) - (byte-compile #'comp-tests-geq-f) - (native-compile #'comp-tests-eqlsign-f) - (native-compile #'comp-tests-gtr-f) - (native-compile #'comp-tests-lss-f) - (native-compile #'comp-tests-les-f) - (native-compile #'comp-tests-geq-f) + (comp-test-compile #'comp-tests-eqlsign-f) + (comp-test-compile #'comp-tests-gtr-f) + (comp-test-compile #'comp-tests-lss-f) + (comp-test-compile #'comp-tests-les-f) + (comp-test-compile #'comp-tests-geq-f) (should (eq (comp-tests-eqlsign-f 4 3) nil)) (should (eq (comp-tests-eqlsign-f 3 3) t)) @@ -348,10 +320,8 @@ (setcdr x y) x) - (byte-compile #'comp-tests-setcar-f) - (byte-compile #'comp-tests-setcdr-f) - (native-compile #'comp-tests-setcar-f) - (native-compile #'comp-tests-setcdr-f) + (comp-test-compile #'comp-tests-setcar-f) + (comp-test-compile #'comp-tests-setcdr-f) (should (equal (comp-tests-setcar-f '(10 . 10) 3) '(3 . 10))) (should (equal (comp-tests-setcdr-f '(10 . 10) 3) '(10 . 3))) @@ -380,8 +350,7 @@ (setq i (1- i))) list)) - (byte-compile #'comp-bubble-sort-f) - (native-compile #'comp-bubble-sort-f) + (comp-test-compile #'comp-bubble-sort-f) (let* ((list1 (mapcar 'random (make-list 1000 most-positive-fixnum))) (list2 (copy-sequence list1))) @@ -397,10 +366,8 @@ ;; Bsetcar (setcar x 3)) - (byte-compile #'comp-tests-consp-f) - (native-compile #'comp-tests-consp-f) - (byte-compile #'comp-tests-car-f) - (native-compile #'comp-tests-car-f) + (comp-test-compile #'comp-tests-consp-f) + (comp-test-compile #'comp-tests-car-f) (should (eq (comp-tests-consp-f '(1)) t)) (should (eq (comp-tests-consp-f 1) nil)) @@ -417,10 +384,8 @@ ;; Bnumberp (numberp x)) - (byte-compile #'comp-tests-integerp-f) - (native-compile #'comp-tests-integerp-f) - (byte-compile #'comp-tests-numberp-f) - (native-compile #'comp-tests-numberp-f) + (comp-test-compile #'comp-tests-integerp-f) + (comp-test-compile #'comp-tests-numberp-f) (should (eq (comp-tests-integerp-f 1) t)) (should (eq (comp-tests-integerp-f '(1)) nil)) @@ -443,10 +408,8 @@ ;; Binsert (insert a b c d)) - (byte-compile #'comp-tests-discardn-f) - (native-compile #'comp-tests-discardn-f) - (byte-compile #'comp-tests-insertn-f) - (native-compile #'comp-tests-insertn-f) + (comp-test-compile #'comp-tests-discardn-f) + (comp-test-compile #'comp-tests-insertn-f) (should (= (comp-tests-discardn-f 10) 2)) @@ -493,14 +456,10 @@ (defun comp-tests-throw-f (x) (throw 'foo x)) - (byte-compile #'comp-tests-condition-case-0-f) - (native-compile #'comp-tests-condition-case-0-f) - (byte-compile #'comp-tests-condition-case-1-f) - (native-compile #'comp-tests-condition-case-1-f) - (byte-compile #'comp-tests-catch-f) - (native-compile #'comp-tests-catch-f) - (byte-compile #'comp-tests-throw-f) - (native-compile #'comp-tests-throw-f) + (comp-test-compile #'comp-tests-condition-case-0-f) + (comp-test-compile #'comp-tests-condition-case-1-f) + (comp-test-compile #'comp-tests-catch-f) + (comp-test-compile #'comp-tests-throw-f) (should (string= (comp-tests-condition-case-0-f) "arith-error Arithmetic error catched")) commit 02bd9340e2d81dcdc991c4cc47888b2404e56110 Author: Andrea Corallo Date: Mon Jul 8 07:17:28 2019 +0200 some code for const propagation diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 4253375942..8ed75e0a4b 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -37,6 +37,15 @@ (defconst comp-known-ret-types '((Fcons . cons))) +(defconst comp-mostly-pure-funcs + '(% * + - / /= 1+ 1- < <= = > >= cons list % concat logand logcount logior + lognot logxor regexp-opt regexp-quote string-to-char string-to-syntax + symbol-name) + "Functions on witch we do constant propagation." + ;; Is it acceptable to move into the compile time functions that are + ;; allocating memory? (these are technically not side effect free) +) + (cl-defstruct comp-args mandatory nonrest rest) @@ -105,6 +114,13 @@ "Slot into the meta-stack pointed by sp + 1." '(comp-slot-n (1+ (comp-sp)))) +;; (defun comp-opt-call (inst) +;; "Optimize if possible a side-effect-free call in INST." +;; (cl-destructuring-bind (_ f &rest args) inst +;; (when (and (member f comp-mostly-pure-funcs) +;; (cl-every #'identity (mapcar #'comp-mvar-const-vld args))) +;; (apply f (mapcar #'comp-mvar-constant args))))) + (defmacro comp-push-call (x) "Push call X into frame." `(let ((src-slot ,x)) commit 2782a07f4d9b8ebc0e89c2b1350aa05c1fd41158 Author: Andrea Corallo Date: Sun Jul 7 22:04:50 2019 +0200 add lists car and cdr diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index c1248ca327..4253375942 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -130,8 +130,8 @@ X value is known at compile time." `(let ((val ,x)) (cl-incf (comp-sp)) (setf (comp-slot) (make-comp-mvar :slot (comp-sp) - :const-vld t - :constant val)) + :const-vld t + :constant val)) (push (list '=const (comp-slot) val) ir))) (defmacro comp-pop (n) @@ -141,33 +141,44 @@ X value is known at compile time." (defun comp-limplify-lap-inst (inst frame ir) "Limplify LAP instruction INST in current FRAME accumulating in IR. Return the new head." - (let ((op (car inst))) - (pcase op - ('byte-dup - (comp-push-slot-n (comp-sp))) - ('byte-varref - (comp-push-call `(call Fsymbol_value ,(second inst)))) - ('byte-constant - (comp-push-const (second inst))) - ('byte-stack-ref - (comp-push-slot-n (- (comp-sp) (cdr inst)))) - ('byte-plus - (comp-pop 2) - (comp-push-call `(callref Fplus 2 ,(comp-sp)))) - ('byte-car - (comp-pop 1) - (comp-push-call `(call Fcar ,(comp-sp)))) - ('byte-list3 - (comp-pop 1) - (comp-push-call `(call Fcons ,(comp-slot-next) nil)) - (dotimes (_ 1) + (cl-flet ((do-list (n) + (comp-pop 1) + (comp-push-call `(call Fcons ,(comp-slot-next) nil)) + (dotimes (_ (1- n)) + (comp-pop 2) + (comp-push-call `(call Fcons + ,(comp-slot-next) + ,(comp-slot-n (+ 2 (comp-sp)))))))) + (let ((op (car inst))) + (pcase op + ('byte-dup + (comp-push-slot-n (comp-sp))) + ('byte-varref + (comp-push-call `(call Fsymbol_value ,(second inst)))) + ('byte-constant + (comp-push-const (second inst))) + ('byte-stack-ref + (comp-push-slot-n (- (comp-sp) (cdr inst)))) + ('byte-plus (comp-pop 2) - (comp-push-call `(call Fcons - ,(comp-slot) - ,(comp-slot-next))))) - ('byte-return - `(return ,(comp-slot))) - (_ (error "Unexpected LAP op %s" (symbol-name op))))) + (comp-push-call `(callref Fplus 2 ,(comp-sp)))) + ('byte-car + (comp-pop 1) + (comp-push-call `(call Fcar ,(comp-sp)))) + ('byte-cdr + (comp-pop 1) + (comp-push-call `(call Fcdr ,(comp-sp)))) + ('byte-list1 + (do-list 1)) + ('byte-list2 + (do-list 2)) + ('byte-list3 + (do-list 3)) + ('byte-list4 + (do-list 4)) + ('byte-return + `(return ,(comp-slot))) + (_ (error "Unexpected LAP op %s" (symbol-name op)))))) ir) (defun comp-limplify (ir) commit 85eb3adf002d3ffd61756329b830902e446650ec Author: Andrea Corallo Date: Sun Jul 7 21:49:11 2019 +0200 working on diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 99f34a069d..c1248ca327 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -35,6 +35,8 @@ comp-limplify) "Passes to be executed in order.") +(defconst comp-known-ret-types '((Fcons . cons))) + (cl-defstruct comp-args mandatory nonrest rest) @@ -50,12 +52,12 @@ :documentation "Current intermediate rappresentation") (args nil :type 'comp-args)) -(cl-defstruct (comp-meta-var (:copier nil)) - "A frame slot into the meta-stack." +(cl-defstruct (comp-mvar (:copier nil)) + "A meta-variable being a slot in the meta-stack." (slot nil :type fixnum - :documentation "Slot position into the meta-stack") + :documentation "Slot position") (const-vld nil - :documentation "Valid for the following slot") + :documentation "Valid signal for the following slot") (constant nil :documentation "When const-vld non nil this is used for constant propagation") @@ -99,11 +101,19 @@ "Current slot into the meta-stack pointed by sp." '(comp-slot-n (comp-sp))) -(defmacro comp-push (x) - "Push X into frame." - `(progn +(defmacro comp-slot-next () + "Slot into the meta-stack pointed by sp + 1." + '(comp-slot-n (1+ (comp-sp)))) + +(defmacro comp-push-call (x) + "Push call X into frame." + `(let ((src-slot ,x)) (cl-incf (comp-sp)) - (list '= (comp-slot) ,x))) + (setf (comp-slot) + (make-comp-mvar :slot (comp-sp) + :type (alist-get (second src-slot) + comp-known-ret-types))) + (push (list '=call (comp-slot) src-slot) ir))) (defmacro comp-push-slot-n (n) "Push slot number N into frame." @@ -111,44 +121,54 @@ (cl-incf (comp-sp)) (setf (comp-slot) (copy-sequence src-slot)) - (setf (comp-meta-var-slot (comp-slot)) (comp-sp)) - (list '=slot (comp-slot) src-slot))) + (setf (comp-mvar-slot (comp-slot)) (comp-sp)) + (push (list '=slot (comp-slot) src-slot) ir))) (defmacro comp-push-const (x) "Push X into frame. X value is known at compile time." - `(progn + `(let ((val ,x)) (cl-incf (comp-sp)) - (setf (comp-slot) (make-comp-meta-var :slot (comp-sp) + (setf (comp-slot) (make-comp-mvar :slot (comp-sp) :const-vld t - :constant ,x)) - (list '=const (comp-slot) ,x))) + :constant val)) + (push (list '=const (comp-slot) val) ir))) (defmacro comp-pop (n) "Pop N elements from the meta-stack." `(cl-decf (comp-sp) ,n)) -(defun comp-limplify-lap-inst (inst frame) - "Limplify LAP instruction INST in current FRAME." +(defun comp-limplify-lap-inst (inst frame ir) + "Limplify LAP instruction INST in current FRAME accumulating in IR. +Return the new head." (let ((op (car inst))) (pcase op ('byte-dup (comp-push-slot-n (comp-sp))) ('byte-varref - (comp-push `(call Fsymbol_value ,(second inst)))) + (comp-push-call `(call Fsymbol_value ,(second inst)))) ('byte-constant (comp-push-const (second inst))) ('byte-stack-ref (comp-push-slot-n (- (comp-sp) (cdr inst)))) ('byte-plus (comp-pop 2) - (comp-push `(callref Fplus 2 ,(comp-sp)))) + (comp-push-call `(callref Fplus 2 ,(comp-sp)))) ('byte-car (comp-pop 1) - (comp-push `(Fcar ,(comp-sp)))) + (comp-push-call `(call Fcar ,(comp-sp)))) + ('byte-list3 + (comp-pop 1) + (comp-push-call `(call Fcons ,(comp-slot-next) nil)) + (dotimes (_ 1) + (comp-pop 2) + (comp-push-call `(call Fcons + ,(comp-slot) + ,(comp-slot-next))))) ('byte-return `(return ,(comp-slot))) - (_ 'xxx)))) + (_ (error "Unexpected LAP op %s" (symbol-name op))))) + ir) (defun comp-limplify (ir) "Given IR and return LIMPLE." @@ -157,7 +177,7 @@ X value is known at compile time." :sp -1 :frame (let ((v (make-vector frame-size nil))) (cl-loop for i below frame-size - do (aset v i (make-comp-meta-var :slot i))) + do (aset v i (make-comp-mvar :slot i))) v))) (limple-ir ())) ;; Prologue @@ -167,8 +187,9 @@ X value is known at compile time." (cl-incf (comp-sp)) (push `(=par ,(comp-slot) ,i) limple-ir))) (push '(BLOCK body) limple-ir) - (cl-loop for inst in (comp-func-ir ir) - do (push (comp-limplify-lap-inst inst frame) limple-ir)) + (mapc (lambda (inst) + (setq limple-ir (comp-limplify-lap-inst inst frame limple-ir))) + (comp-func-ir ir)) (setq limple-ir (reverse limple-ir)) (setf (comp-func-ir ir) limple-ir) (when comp-debug commit 83d1a34ef975ea40bb840d6a0eeb37b407d4cb9e Author: Andrea Corallo Date: Sun Jul 7 18:42:55 2019 +0200 first limple diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 9b3bb98e39..99f34a069d 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -91,24 +91,28 @@ "Current stack pointer." '(comp-limple-frame-sp frame)) +(defmacro comp-slot-n (n) + "Slot N into the meta-stack." + `(aref (comp-limple-frame-frame frame) ,n)) + (defmacro comp-slot () "Current slot into the meta-stack pointed by sp." - '(aref (comp-limple-frame-frame frame) (comp-sp))) + '(comp-slot-n (comp-sp))) -(defmacro comp-push (n) - "Push slot number N into frame." +(defmacro comp-push (x) + "Push X into frame." `(progn (cl-incf (comp-sp)) - (list '= (comp-slot) ,n))) + (list '= (comp-slot) ,x))) -(defmacro comp-push-slot (n) +(defmacro comp-push-slot-n (n) "Push slot number N into frame." - `(let ((src-slot (aref (comp-limple-frame-frame frame) ,n))) + `(let ((src-slot (comp-slot-n ,n))) (cl-incf (comp-sp)) (setf (comp-slot) (copy-sequence src-slot)) (setf (comp-meta-var-slot (comp-slot)) (comp-sp)) - (list '= (comp-slot) src-slot))) + (list '=slot (comp-slot) src-slot))) (defmacro comp-push-const (x) "Push X into frame. @@ -118,7 +122,7 @@ X value is known at compile time." (setf (comp-slot) (make-comp-meta-var :slot (comp-sp) :const-vld t :constant ,x)) - (list '= (comp-slot) ,x))) + (list '=const (comp-slot) ,x))) (defmacro comp-pop (n) "Pop N elements from the meta-stack." @@ -128,32 +132,44 @@ X value is known at compile time." "Limplify LAP instruction INST in current FRAME." (let ((op (car inst))) (pcase op + ('byte-dup + (comp-push-slot-n (comp-sp))) ('byte-varref (comp-push `(call Fsymbol_value ,(second inst)))) ('byte-constant (comp-push-const (second inst))) ('byte-stack-ref - (comp-push-slot (- (comp-sp) (cdr inst)))) + (comp-push-slot-n (- (comp-sp) (cdr inst)))) ('byte-plus (comp-pop 2) (comp-push `(callref Fplus 2 ,(comp-sp)))) + ('byte-car + (comp-pop 1) + (comp-push `(Fcar ,(comp-sp)))) ('byte-return - `(return ,(comp-sp))) + `(return ,(comp-slot))) (_ 'xxx)))) (defun comp-limplify (ir) - "Take IR and return LIMPLE." + "Given IR and return LIMPLE." (let* ((frame-size (aref (comp-func-byte-func ir) 3)) (frame (make-comp-limple-frame - :sp (1- (comp-args-mandatory (comp-func-args ir))) + :sp -1 :frame (let ((v (make-vector frame-size nil))) (cl-loop for i below frame-size do (aset v i (make-comp-meta-var :slot i))) v))) - (limple-ir - (cl-loop - for inst in (comp-func-ir ir) - collect (comp-limplify-lap-inst inst frame)))) + (limple-ir ())) + ;; Prologue + (push '(BLOCK prologue) limple-ir) + (cl-loop for i below (comp-args-mandatory (comp-func-args ir)) + do (progn + (cl-incf (comp-sp)) + (push `(=par ,(comp-slot) ,i) limple-ir))) + (push '(BLOCK body) limple-ir) + (cl-loop for inst in (comp-func-ir ir) + do (push (comp-limplify-lap-inst inst frame) limple-ir)) + (setq limple-ir (reverse limple-ir)) (setf (comp-func-ir ir) limple-ir) (when comp-debug (cl-prettyprint (comp-func-ir ir))) commit 8d0ae21c4847e5b78d3dd19325821414095c2756 Author: Andrea Corallo Date: Sun Jul 7 12:30:03 2019 +0200 working on comp.el diff --git a/lisp/emacs-lisp/byte-run.el b/lisp/emacs-lisp/byte-run.el index 6a49c60099..fedbd61ffd 100644 --- a/lisp/emacs-lisp/byte-run.el +++ b/lisp/emacs-lisp/byte-run.el @@ -597,4 +597,6 @@ Otherwise, return nil. For internal use only." (make-obsolete 'macro-declaration-function 'macro-declarations-alist "24.3") +(provide 'byte-run) + ;;; byte-run.el ends here diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 2617142c62..fa3f5a7f9b 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -124,6 +124,7 @@ (require 'backquote) (require 'macroexp) (require 'cconv) +(require 'byte-run) (eval-when-compile (require 'compile)) ;; Refrain from using cl-lib at run-time here, since it otherwise prevents ;; us from emitting warnings when compiling files which use cl-lib without diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index d72127a6eb..9b3bb98e39 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -22,27 +22,156 @@ ;;; Code: -(require 'disass) +(require 'bytecomp) (eval-when-compile (require 'cl-lib)) (defgroup comp nil "Emacs Lisp native compiler." :group 'lisp) -(defun comp-recuparate-lap (fun) - "Compile FUN if necessary and recuparate its LAP rapresentation." - (byte-compile-close-variables - (byte-compile-top-level (byte-compile-preprocess fun)) - byte-compile-lap-output)) +(defconst comp-debug t) -(defun comp-compute-blocks (obj) - "Split OBJ in basic blocks." - obj) +(defconst comp-passes '(comp-recuparate-lap + comp-limplify) + "Passes to be executed in order.") + +(cl-defstruct comp-args + mandatory nonrest rest) + +(cl-defstruct (comp-func (:copier nil)) + "Internal rapresentation for a function." + (symbol-name nil + :documentation "Function symbol's name") + (func nil + :documentation "Original form") + (byte-func nil + :documentation "Byte compiled version") + (ir nil + :documentation "Current intermediate rappresentation") + (args nil :type 'comp-args)) + +(cl-defstruct (comp-meta-var (:copier nil)) + "A frame slot into the meta-stack." + (slot nil :type fixnum + :documentation "Slot position into the meta-stack") + (const-vld nil + :documentation "Valid for the following slot") + (constant nil + :documentation "When const-vld non nil this is used for constant + propagation") + (type nil + :documentation "When non nil is used for type propagation")) + +(cl-defstruct (comp-limple-frame (:copier nil)) + "A LIMPLE func." + (sp 0 :type 'fixnum + :documentation "Current stack pointer") + (frame nil :type 'vector + :documentation "Meta-stack used to flat LAP")) + +(defun comp-decrypt-lambda-list (x) + "Decript lambda list X." + (make-comp-args :rest (not (= (logand x 128) 0)) + :mandatory (logand x 127) + :nonrest (ash x -8))) + +(defun comp-recuparate-lap (ir) + "Byte compile and recuparate LAP rapresentation for IR." + ;; FIXME block timers here, otherwise we could spill the wrong LAP. + (setf (comp-func-byte-func ir) + (byte-compile (comp-func-symbol-name ir))) + (when comp-debug + (cl-prettyprint byte-compile-lap-output)) + (setf (comp-func-args ir) + (comp-decrypt-lambda-list (aref (comp-func-byte-func ir) 0))) + (setf (comp-func-ir ir) byte-compile-lap-output) + ir) + +(defmacro comp-sp () + "Current stack pointer." + '(comp-limple-frame-sp frame)) + +(defmacro comp-slot () + "Current slot into the meta-stack pointed by sp." + '(aref (comp-limple-frame-frame frame) (comp-sp))) + +(defmacro comp-push (n) + "Push slot number N into frame." + `(progn + (cl-incf (comp-sp)) + (list '= (comp-slot) ,n))) + +(defmacro comp-push-slot (n) + "Push slot number N into frame." + `(let ((src-slot (aref (comp-limple-frame-frame frame) ,n))) + (cl-incf (comp-sp)) + (setf (comp-slot) + (copy-sequence src-slot)) + (setf (comp-meta-var-slot (comp-slot)) (comp-sp)) + (list '= (comp-slot) src-slot))) + +(defmacro comp-push-const (x) + "Push X into frame. +X value is known at compile time." + `(progn + (cl-incf (comp-sp)) + (setf (comp-slot) (make-comp-meta-var :slot (comp-sp) + :const-vld t + :constant ,x)) + (list '= (comp-slot) ,x))) + +(defmacro comp-pop (n) + "Pop N elements from the meta-stack." + `(cl-decf (comp-sp) ,n)) + +(defun comp-limplify-lap-inst (inst frame) + "Limplify LAP instruction INST in current FRAME." + (let ((op (car inst))) + (pcase op + ('byte-varref + (comp-push `(call Fsymbol_value ,(second inst)))) + ('byte-constant + (comp-push-const (second inst))) + ('byte-stack-ref + (comp-push-slot (- (comp-sp) (cdr inst)))) + ('byte-plus + (comp-pop 2) + (comp-push `(callref Fplus 2 ,(comp-sp)))) + ('byte-return + `(return ,(comp-sp))) + (_ 'xxx)))) + +(defun comp-limplify (ir) + "Take IR and return LIMPLE." + (let* ((frame-size (aref (comp-func-byte-func ir) 3)) + (frame (make-comp-limple-frame + :sp (1- (comp-args-mandatory (comp-func-args ir))) + :frame (let ((v (make-vector frame-size nil))) + (cl-loop for i below frame-size + do (aset v i (make-comp-meta-var :slot i))) + v))) + (limple-ir + (cl-loop + for inst in (comp-func-ir ir) + collect (comp-limplify-lap-inst inst frame)))) + (setf (comp-func-ir ir) limple-ir) + (when comp-debug + (cl-prettyprint (comp-func-ir ir))) + ir)) (defun native-compile (fun) "FUN is the function definition to be compiled to native code." + (unless lexical-binding + (error "Can't compile a non lexical binded function")) (if-let ((f (symbol-function fun))) - (comp-recuparate-lap f) + (progn + (when (byte-code-function-p f) + (error "Can't native compile an already bytecompiled function")) + (cl-loop with ir = (make-comp-func :symbol-name fun + :func f) + for pass in comp-passes + do (funcall pass ir) + finally return ir)) (error "Trying to native compile not a function"))) (provide 'comp) commit adeb0183c72cba367b2896dc67eb6afd750ec693 Author: Andrea Corallo Date: Sun Jul 7 10:35:20 2019 +0200 spill lap diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 40cf821720..2617142c62 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -559,6 +559,7 @@ outputting warnings about functions not being defined at runtime.") (defvar byte-compile-output nil "Alist describing contents to put in byte code string. Each element is (INDEX . VALUE)") +(defvar byte-compile-lap-output nil) (defvar byte-compile-depth 0 "Current depth of execution stack.") (defvar byte-compile-maxdepth 0 "Maximum depth of execution stack.") @@ -3111,6 +3112,8 @@ for symbols generated by the byte compiler itself." (not (delq nil (mapcar 'consp (cdr (car body)))))))) (setq rest (cdr rest))) rest)) + ;; Spill lap output here + (setq byte-compile-lap-output byte-compile-output) (let ((byte-compile-vector (byte-compile-constants-vector))) (list 'byte-code (byte-compile-lapcode byte-compile-output) byte-compile-vector byte-compile-maxdepth))) commit 15402fe9dbdacd598a723e3b39fc9e90032680cd Author: Andrea Corallo Date: Sun Jul 7 09:23:10 2019 +0200 add comp.el diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el new file mode 100644 index 0000000000..d72127a6eb --- /dev/null +++ b/lisp/emacs-lisp/comp.el @@ -0,0 +1,50 @@ +;;; comp.el --- compilation of Lisp code into native code -*- lexical-binding: t -*- + +;; Copyright (C) 2019 Free Software Foundation, Inc. + +;; Keywords: lisp +;; Package: emacs + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Code: + +(require 'disass) +(eval-when-compile (require 'cl-lib)) + +(defgroup comp nil + "Emacs Lisp native compiler." + :group 'lisp) + +(defun comp-recuparate-lap (fun) + "Compile FUN if necessary and recuparate its LAP rapresentation." + (byte-compile-close-variables + (byte-compile-top-level (byte-compile-preprocess fun)) + byte-compile-lap-output)) + +(defun comp-compute-blocks (obj) + "Split OBJ in basic blocks." + obj) + +(defun native-compile (fun) + "FUN is the function definition to be compiled to native code." + (if-let ((f (symbol-function fun))) + (comp-recuparate-lap f) + (error "Trying to native compile not a function"))) + +(provide 'comp) + +;;; comp.el ends here commit cfcfd1fe8d6e16b85bf28a09582b81683e263db2 Author: Andrea Corallo Date: Sat Jul 6 19:51:53 2019 +0200 fix jump table diff --git a/src/comp.c b/src/comp.c index 54f6602c52..4837b12210 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1853,7 +1853,6 @@ compute_blocks (ptrdiff_t bytestr_length, unsigned char *bytestr_data, case Bvarbind6: case Bcall6: case Bunbind6: - case Bconstant2: case BlistN: case BconcatN: case BinsertN: @@ -1895,11 +1894,12 @@ compute_blocks (ptrdiff_t bytestr_length, unsigned char *bytestr_data, /* Handled in Bconstant case. */ emacs_abort (); break; + case Bconstant2: + op = FETCH2; + FALLTHROUGH; + default: case Bconstant: { - if (!(Bconstant <= op && op < Bconstant + const_length)) - emacs_abort (); - if (bytestr_data[pc] != Bswitch) break; /* Jump table with following Bswitch. */ @@ -1915,8 +1915,6 @@ compute_blocks (ptrdiff_t bytestr_length, unsigned char *bytestr_data, bb_start_pc[bb_n++] = pc; ++pc; } - default: - break; } } @@ -3032,8 +3030,8 @@ compile_f (const char *lisp_f_name, const char *c_f_name, CASE_CALL_N (end_of_line, 1); CASE (Bconstant2); - goto do_constant; - break; + op = FETCH2; + goto do_constant; CASE (Bgoto); op = FETCH2; commit ccc719b230776b856aa4bf581ff19fd681a1aa56 Author: Andrea Corallo Date: Sat Jul 6 16:43:09 2019 +0200 jump table support diff --git a/src/comp.c b/src/comp.c index d705b5fa70..54f6602c52 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1816,7 +1816,8 @@ ucmp(const void *a, const void *b) /* Compute and initialize all basic blocks. */ static basic_block_t * -compute_blocks (ptrdiff_t bytestr_length, unsigned char *bytestr_data) +compute_blocks (ptrdiff_t bytestr_length, unsigned char *bytestr_data, + Lisp_Object *vectorp, ptrdiff_t const_length) { ptrdiff_t pc = 0; unsigned op; @@ -1890,6 +1891,30 @@ compute_blocks (ptrdiff_t bytestr_length, unsigned char *bytestr_data) case Breturn: new_bb = true; break; + case Bswitch: + /* Handled in Bconstant case. */ + emacs_abort (); + break; + case Bconstant: + { + if (!(Bconstant <= op && op < Bconstant + const_length)) + emacs_abort (); + + if (bytestr_data[pc] != Bswitch) + break; + /* Jump table with following Bswitch. */ + ++pc; + op -= Bconstant; + struct Lisp_Hash_Table *h = XHASH_TABLE (vectorp[op]); + for (ptrdiff_t i = 0; i < HASH_TABLE_SIZE (h); ++i) + if (!NILP (HASH_HASH (h, i))) + { + Lisp_Object pc = HASH_VALUE (h, i); + bb_start_pc[bb_n++] = XFIXNUM (pc); + } + bb_start_pc[bb_n++] = pc; + ++pc; + } default: break; } @@ -2082,7 +2107,7 @@ static comp_f_res_t compile_f (const char *lisp_f_name, const char *c_f_name, ptrdiff_t bytestr_length, unsigned char *bytestr_data, EMACS_INT stack_depth, Lisp_Object *vectorp, - ptrdiff_t vector_size, Lisp_Object args_template) + ptrdiff_t const_length, Lisp_Object args_template) { USE_SAFE_ALLOCA; gcc_jit_rvalue *res; @@ -2169,7 +2194,8 @@ compile_f (const char *lisp_f_name, const char *c_f_name, DECL_AND_SAFE_ALLOCA_BLOCK(prologue, comp.func); comp.block = prologue; - basic_block_t *bb_map = compute_blocks (bytestr_length, bytestr_data); + basic_block_t *bb_map = + compute_blocks (bytestr_length, bytestr_data, vectorp, const_length); if (!parse_args) { @@ -3281,7 +3307,6 @@ compile_f (const char *lisp_f_name, const char *c_f_name, DISCARD (op); break; CASE (Bswitch); - error ("Bswitch not supported"); /* The cases of Bswitch that we handle (which in theory is all of them) are done in Bconstant, below. This is done due to a design issue with Bswitch -- it should have @@ -3293,7 +3318,7 @@ compile_f (const char *lisp_f_name, const char *c_f_name, default: CASE (Bconstant); { - if (op < Bconstant || op > Bconstant + vector_size) + if (op < Bconstant || op > Bconstant + const_length) goto fail; op -= Bconstant; @@ -3316,8 +3341,27 @@ compile_f (const char *lisp_f_name, const char *c_f_name, break; } - /* We're compiling Bswitch instead. */ + /* Jump table with following Bswitch. */ ++pc; + + struct Lisp_Hash_Table *h = XHASH_TABLE (vectorp[op]); + POP1; + basic_block_t *jump_block; + for (ptrdiff_t i = 0; i < HASH_TABLE_SIZE (h); ++i) + if (!NILP (HASH_HASH (h, i))) + { + SAFE_ALLOCA_BLOCK (jump_block, + comp.func, + format_string ("jump_t_%ld", + i)); + ptrdiff_t target_pc = XFIXNUM (HASH_VALUE (h, i)); + gcc_jit_rvalue *val = + emit_lisp_obj_from_ptr (HASH_KEY (h, i)); + emit_cond_jump (emit_EQ (args[0], val), &bb_map[target_pc], + jump_block); + comp.block = jump_block; + } + break; } } diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index d732d558cd..b6a8904347 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -218,6 +218,21 @@ (should (= (comp-tests-ffuncall-lambda-f 1) 2))) +(ert-deftest comp-tests-jump-table () + "Testing jump tables" + (defun comp-tests-jump-table-1-f (x) + (pcase x + ('x 'a) + ('y 'b) + (_ 'c))) + + (byte-compile #'comp-tests-jump-table-1-f) + (byte-compile #'comp-tests-jump-table-1-f) + + (should (eq (comp-tests-jump-table-1-f 'x) 'a)) + (should (eq (comp-tests-jump-table-1-f 'y) 'b)) + (should (eq (comp-tests-jump-table-1-f 'xxx) 'c))) + (ert-deftest comp-tests-conditionals () "Testing conditionals." (defun comp-tests-conditionals-1-f (x) commit 98b500a0a21b486a98bf4e1ae989fd38616164bc Author: Andrea Corallo Date: Sat Jul 6 11:02:52 2019 +0200 optimize outgoing native manyarg calls diff --git a/src/comp.c b/src/comp.c index 0fadeaad11..d705b5fa70 100644 --- a/src/comp.c +++ b/src/comp.c @@ -2398,12 +2398,10 @@ compile_f (const char *lisp_f_name, const char *c_f_name, docall: { res = NULL; - ptrdiff_t nargs = op + 1; - pop (nargs, &stack, args); + pop (op + 1, &stack, args); if (stack->const_set && stack->type == Lisp_Symbol) { - ptrdiff_t native_nargs = op; char *sym_name = (char *) SDATA (SYMBOL_NAME (stack->constant)); if (!strcmp (sym_name, lisp_f_name)) @@ -2412,24 +2410,49 @@ compile_f (const char *lisp_f_name, const char *c_f_name, res = gcc_jit_context_new_call (comp.ctxt, NULL, comp.func, - native_nargs, + op, args + 1); } else if (SUBRP ((XSYMBOL (stack->constant)->u.s.function))) { /* Optimize primitive native calls. */ emit_comment (format_string ("Calling primitive %s", sym_name)); + /* FIXME we really should check is a primitive too!! */ struct Lisp_Subr *subr = XSUBR ((XSYMBOL (stack->constant)->u.s.function)); if (subr->max_args == MANY) { - /* FIXME: do we want to optimize this case too? */ - goto dofuncall; + /* f (nargs, args); */ + args[0] = + gcc_jit_context_new_rvalue_from_int ( + comp.ctxt, + comp.ptrdiff_type, + op); + args[1] = + gcc_jit_lvalue_get_address ((stack + 1)->gcc_lval, + NULL); + gcc_jit_type *types[] = + { comp.ptrdiff_type, comp.lisp_obj_ptr_type }; + gcc_jit_type *fn_ptr_type = + gcc_jit_context_new_function_ptr_type ( + comp.ctxt, + NULL, + comp.lisp_obj_type, + 2, types, 0); + res = + gcc_jit_context_new_call_through_ptr ( + comp.ctxt, + NULL, + gcc_jit_context_new_rvalue_from_ptr ( + comp.ctxt, + fn_ptr_type, + subr->function.a0), + 2, args); } else { - gcc_jit_type *types[native_nargs]; + gcc_jit_type *types[op]; - for (int i = 0; i < native_nargs; i++) + for (int i = 0; i < op; i++) types[i] = comp.lisp_obj_type; gcc_jit_type *fn_ptr_type = @@ -2437,7 +2460,7 @@ compile_f (const char *lisp_f_name, const char *c_f_name, comp.ctxt, NULL, comp.lisp_obj_type, - native_nargs, + op, types, 0); res = @@ -2448,15 +2471,14 @@ compile_f (const char *lisp_f_name, const char *c_f_name, comp.ctxt, fn_ptr_type, subr->function.a0), - native_nargs, + op, args + 1); } } } - dofuncall: /* Fall back to regular funcall dispatch mechanism. */ if (!res) - res = emit_call_n_ref ("Ffuncall", nargs, stack->gcc_lval); + res = emit_call_n_ref ("Ffuncall", op + 1, stack->gcc_lval); PUSH_RVAL (res); break; diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index ef8e57c40c..d732d558cd 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -189,7 +189,16 @@ (byte-compile #'comp-tests-ffuncall-native-f) (native-compile #'comp-tests-ffuncall-native-f) - (should (vectorp (comp-tests-ffuncall-native-f))) + (should (equal (comp-tests-ffuncall-native-f) [nil])) + + (defun comp-tests-ffuncall-native-rest-f () + "Call a primitive with no dedicate op with &rest." + (vector 1 2 3)) + + (byte-compile #'comp-tests-ffuncall-native-rest-f) + (native-compile #'comp-tests-ffuncall-native-rest-f) + + (should (equal (comp-tests-ffuncall-native-rest-f) [1 2 3])) (defun comp-tests-ffuncall-apply-many-f (x) (apply #'list x)) commit 4992fba7c56a4e7de8af4e79305883b505a84da4 Author: Andrea Corallo Date: Sat Jul 6 09:27:45 2019 +0200 rework COMP_DEBUG strategy diff --git a/src/comp.c b/src/comp.c index eefe8db2e2..0fadeaad11 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1931,23 +1931,22 @@ init_comp (int opt_level) if (COMP_DEBUG) { - logfile = fopen ("libgccjit.log", "w"); - gcc_jit_context_set_logfile (comp.ctxt, - logfile, - 0, 0); gcc_jit_context_set_bool_option (comp.ctxt, - GCC_JIT_BOOL_OPTION_KEEP_INTERMEDIATES, + GCC_JIT_BOOL_OPTION_DEBUGINFO, 1); } if (COMP_DEBUG > 1) { + logfile = fopen ("libgccjit.log", "w"); + gcc_jit_context_set_logfile (comp.ctxt, + logfile, + 0, 0); gcc_jit_context_set_bool_option (comp.ctxt, - GCC_JIT_BOOL_OPTION_DEBUGINFO, + GCC_JIT_BOOL_OPTION_KEEP_INTERMEDIATES, 1); gcc_jit_context_set_bool_option (comp.ctxt, - GCC_JIT_BOOL_OPTION_DUMP_INITIAL_GIMPLE, + GCC_JIT_BOOL_OPTION_DUMP_EVERYTHING, 1); - gcc_jit_context_dump_reproducer_to_file (comp.ctxt, "comp_reproducer.c"); } @@ -2072,8 +2071,6 @@ init_comp (int opt_level) static void release_comp (void) { - if (COMP_DEBUG) - gcc_jit_context_dump_to_file (comp.ctxt, "gcc-ctxt-dump.c", 1); if (comp.ctxt) gcc_jit_context_release(comp.ctxt); @@ -3304,6 +3301,8 @@ compile_f (const char *lisp_f_name, const char *c_f_name, } } + if (COMP_DEBUG) + gcc_jit_context_dump_to_file (comp.ctxt, "gcc-ctxt-dump.c", 1); comp_res.gcc_res = gcc_jit_context_compile(comp.ctxt); goto exit; @@ -3363,9 +3362,9 @@ emacs_native_compile (const char *lisp_f_name, const char *c_f_name, if (dump_asm) { - gcc_jit_context_compile_to_file(comp.ctxt, - GCC_JIT_OUTPUT_KIND_ASSEMBLER, - DISASS_FILE_NAME); + gcc_jit_context_compile_to_file (comp.ctxt, + GCC_JIT_OUTPUT_KIND_ASSEMBLER, + DISASS_FILE_NAME); } unblock_atimers (&oldset); release_comp (); commit 36c9295e41404f1f90a8500d46d79b0e2a53af1e Author: Andrea Corallo Date: Tue Jul 2 23:15:11 2019 +0200 basic &rest working diff --git a/src/comp.c b/src/comp.c index a9b46fc860..eefe8db2e2 100644 --- a/src/comp.c +++ b/src/comp.c @@ -394,53 +394,23 @@ emit_func_declare (const char *f_name, gcc_jit_type *ret_type, unsigned nargs, gcc_jit_rvalue **args, enum gcc_jit_function_kind kind, bool reusable) { - gcc_jit_param *param[4]; - gcc_jit_type *type[4]; + gcc_jit_param *param[nargs]; + gcc_jit_type *type[nargs]; /* If args are passed types are extracted from that otherwise assume params */ /* are all lisp objs. */ if (args) - for (int i = 0; i < nargs; i++) + for (unsigned i = 0; i < nargs; i++) type[i] = gcc_jit_rvalue_get_type (args[i]); else - for (int i = 0; i < nargs; i++) + for (unsigned i = 0; i < nargs; i++) type[i] = comp.lisp_obj_type; - switch (nargs) { - case 4: - param[3] = gcc_jit_context_new_param(comp.ctxt, + for (int i = nargs - 1; i >= 0; i--) + param[i] = gcc_jit_context_new_param(comp.ctxt, NULL, - type[3], - "c"); - /* Fall through */ - FALLTHROUGH; - case 3: - param[2] = gcc_jit_context_new_param(comp.ctxt, - NULL, - type[2], - "c"); - /* Fall through */ - FALLTHROUGH; - case 2: - param[1] = gcc_jit_context_new_param(comp.ctxt, - NULL, - type[1], - "b"); - /* Fall through */ - FALLTHROUGH; - case 1: - param[0] = gcc_jit_context_new_param(comp.ctxt, - NULL, - type[0], - "a"); - /* Fall through */ - FALLTHROUGH; - case 0: - break; - default: - /* Argnum not supported */ - eassert (0); - } + type[i], + format_string ("par_%d", i)); gcc_jit_function *func = gcc_jit_context_new_function(comp.ctxt, NULL, @@ -569,8 +539,8 @@ emit_cast (gcc_jit_type *new_type, gcc_jit_rvalue *obj) /* Emit the equivalent of - ptr[i] - ptr + size_of_ptr_ref * i + + (typeof_ptr) ((uintptr) ptr + size_of_ptr_ref * i) */ static gcc_jit_rvalue * @@ -2144,8 +2114,6 @@ compile_f (const char *lisp_f_name, const char *c_f_name, comp_res.min_args = mandatory; - eassert (!rest); - if (!rest && nonrest < SUBR_MAX_ARGS) { comp_res.max_args = nonrest; @@ -2179,7 +2147,7 @@ compile_f (const char *lisp_f_name, const char *c_f_name, 2, param, 0); - } + } gcc_jit_lvalue *meta_stack_array = @@ -2202,6 +2170,7 @@ compile_f (const char *lisp_f_name, const char *c_f_name, i)); DECL_AND_SAFE_ALLOCA_BLOCK(prologue, comp.func); + comp.block = prologue; basic_block_t *bb_map = compute_blocks (bytestr_length, bytestr_data); @@ -2209,8 +2178,6 @@ compile_f (const char *lisp_f_name, const char *c_f_name, { for (ptrdiff_t i = 0; i < comp_res.max_args; ++i) PUSH_PARAM (gcc_jit_function_get_param (comp.func, i)); - - gcc_jit_block_end_with_jump (prologue->gcc_bb, NULL, bb_map[0].gcc_bb); } else { @@ -2218,92 +2185,58 @@ compile_f (const char *lisp_f_name, const char *c_f_name, nargs will be known at runtime therfore we emit: prologue: - i = 0; - push_nargs_check: - if (i < nargs) goto push_args; else goto bb1; - push_nargs: - local[i] = *(args + sizeof (Lisp_Object) * i); - i = i + 1; - goto push_nargs_check; + local[0] = *args; + ++args; + . + . + . + local[min_args - 1] = *args; + ++args; + local[min_args] = list (nargs - min_args, args); bb_1: . . . */ - DECL_AND_SAFE_ALLOCA_BLOCK(push_nargs_check, comp.func); - DECL_AND_SAFE_ALLOCA_BLOCK(push_nargs, comp.func); - - gcc_jit_rvalue *nargs = - gcc_jit_param_as_rvalue (gcc_jit_function_get_param (comp.func, 0)); - gcc_jit_rvalue *args = - gcc_jit_param_as_rvalue (gcc_jit_function_get_param (comp.func, 1)); - gcc_jit_lvalue *i = gcc_jit_function_new_local (comp.func, - NULL, - comp.ptrdiff_type, - "i"); - gcc_jit_block_add_assignment ( - prologue->gcc_bb, - NULL, - i, - gcc_jit_context_new_rvalue_from_int(comp.ctxt, - comp.ptrdiff_type, - 0)); - - gcc_jit_block_end_with_jump (prologue->gcc_bb, - NULL, - push_nargs_check->gcc_bb); - emit_comparison_jump (GCC_JIT_COMPARISON_LE, - gcc_jit_lvalue_as_rvalue (i), - gcc_jit_param_as_rvalue ( - gcc_jit_function_get_param (comp.func, 0)), /* nargs */ - push_nargs, &bb_map[0]); - gcc_jit_lvalue *arg = - gcc_jit_rvalue_dereference ( - gcc_jit_context_new_binary_op ( - comp.ctxt, - NULL, - GCC_JIT_BINARY_OP_PLUS, - comp.ptrdiff_type, - gcc_jit_param_as_rvalue ( - gcc_jit_function_get_param (comp.func, 1)), /* args */ - gcc_jit_context_new_binary_op ( - comp.ctxt, - NULL, - GCC_JIT_BINARY_OP_MULT, - comp.ptrdiff_type, - gcc_jit_context_new_rvalue_from_int (comp.ctxt, - comp.ptrdiff_type, - sizeof (Lisp_Object)), - gcc_jit_lvalue_as_rvalue (i))), - NULL); - - /* FIXME check side stack values */ - gcc_jit_block_add_assignment ( - push_nargs->gcc_bb, - NULL, - gcc_jit_context_new_array_access ( - comp.ctxt, - NULL, - gcc_jit_lvalue_as_rvalue (meta_stack_array), - gcc_jit_lvalue_as_rvalue (i)), - gcc_jit_lvalue_as_rvalue (arg)); + gcc_jit_lvalue *nargs = + gcc_jit_param_as_lvalue (gcc_jit_function_get_param (comp.func, 0)); + gcc_jit_lvalue *args = + gcc_jit_param_as_lvalue (gcc_jit_function_get_param (comp.func, 1)); + gcc_jit_rvalue *min_args = + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.ptrdiff_type, + comp_res.min_args); + + for (ptrdiff_t i = 0; i < comp_res.min_args; ++i) + { + PUSH_LVAL (gcc_jit_rvalue_dereference ( + gcc_jit_lvalue_as_rvalue (args), + NULL)); + gcc_jit_block_add_assignment (prologue->gcc_bb, + NULL, + args, + emit_ptr_arithmetic ( + gcc_jit_lvalue_as_rvalue (args), + comp.lisp_obj_ptr_type, + sizeof (Lisp_Object), + comp.one)); + } - gcc_jit_block_add_assignment ( - push_nargs->gcc_bb, - NULL, - i, - gcc_jit_context_new_binary_op (comp.ctxt, - NULL, - GCC_JIT_BINARY_OP_PLUS, - comp.ptrdiff_type, - gcc_jit_lvalue_as_rvalue (i), - comp.one)); + /* + rest arguments + */ + gcc_jit_rvalue *list_args[] = + { gcc_jit_context_new_binary_op (comp.ctxt, + NULL, + GCC_JIT_BINARY_OP_MINUS, + comp.ptrdiff_type, + gcc_jit_lvalue_as_rvalue (nargs), + min_args), + gcc_jit_lvalue_as_rvalue (args) }; - gcc_jit_block_end_with_jump (push_nargs->gcc_bb, - NULL, - push_nargs_check->gcc_bb); + PUSH_RVAL (emit_call ("Flist", comp.lisp_obj_type, 2, list_args)); } - + gcc_jit_block_end_with_jump (prologue->gcc_bb, NULL, bb_map[0].gcc_bb); comp.block = &bb_map[0]; gcc_jit_rvalue *nil = emit_lisp_obj_from_ptr (Qnil); diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 7bd4ddf01c..ef8e57c40c 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -164,6 +164,24 @@ (should (equal (comp-tests-ffuncall-caller-f) '(1 2 3))) + (defun comp-tests-ffuncall-callee-optional-f (a b &optional c d) + (list a b c d)) + (byte-compile #'comp-tests-ffuncall-callee-optional-f) + (native-compile #'comp-tests-ffuncall-callee-optional-f) + + (should (equal (comp-tests-ffuncall-callee-optional-f 1 2 3 4) '(1 2 3 4))) + (should (equal (comp-tests-ffuncall-callee-optional-f 1 2 3) '(1 2 3 nil))) + (should (equal (comp-tests-ffuncall-callee-optional-f 1 2) '(1 2 nil nil))) + + (defun comp-tests-ffuncall-callee-rest-f (a b &rest c) + (list a b c)) + (byte-compile #'comp-tests-ffuncall-callee-rest-f) + (native-compile #'comp-tests-ffuncall-callee-rest-f) + + (should (equal (comp-tests-ffuncall-callee-rest-f 1 2) '(1 2 nil))) + (should (equal (comp-tests-ffuncall-callee-rest-f 1 2 3) '(1 2 (3)))) + (should (equal (comp-tests-ffuncall-callee-rest-f 1 2 3 4) '(1 2 (3 4)))) + (defun comp-tests-ffuncall-native-f () "Call a primitive with no dedicate op." (make-vector 1 nil)) commit 193688f2fc34c03a32b1e013d74fd6e5fac845c7 Author: Andrea Corallo Date: Tue Jul 2 23:14:36 2019 +0200 add emit_ptr_arithmetic diff --git a/src/comp.c b/src/comp.c index 301ff83c8e..a9b46fc860 100644 --- a/src/comp.c +++ b/src/comp.c @@ -567,6 +567,41 @@ emit_cast (gcc_jit_type *new_type, gcc_jit_rvalue *obj) dest_field); } +/* + Emit the equivalent of + ptr[i] + ptr + size_of_ptr_ref * i +*/ + +static gcc_jit_rvalue * +emit_ptr_arithmetic (gcc_jit_rvalue *ptr, gcc_jit_type *ptr_type, + int size_of_ptr_ref, gcc_jit_rvalue *i) +{ + emit_comment ("ptr_arithmetic"); + + gcc_jit_rvalue *offset = + gcc_jit_context_new_binary_op ( + comp.ctxt, + NULL, + GCC_JIT_BINARY_OP_MULT, + comp.uintptr_type, + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.uintptr_type, + size_of_ptr_ref), + emit_cast (comp.uintptr_type, i)); + + return + emit_cast ( + ptr_type, + gcc_jit_context_new_binary_op ( + comp.ctxt, + NULL, + GCC_JIT_BINARY_OP_PLUS, + comp.uintptr_type, + emit_cast (comp.uintptr_type, ptr), + offset)); +} + INLINE static gcc_jit_rvalue * emit_XLI (gcc_jit_rvalue *obj) { commit 8c28758b43e16e68d3162b77c632744a6bad3617 Author: Andrea Corallo Date: Tue Jul 2 22:46:23 2019 +0200 extend cast capabilities diff --git a/src/comp.c b/src/comp.c index 970019abe8..301ff83c8e 100644 --- a/src/comp.c +++ b/src/comp.c @@ -246,10 +246,13 @@ typedef struct { gcc_jit_field *cast_union_as_u; gcc_jit_field *cast_union_as_i; gcc_jit_field *cast_union_as_b; + gcc_jit_field *cast_union_as_uintptr; + gcc_jit_field *cast_union_as_ptrdiff; gcc_jit_field *cast_union_as_c_p; gcc_jit_field *cast_union_as_v_p; gcc_jit_field *cast_union_as_lisp_cons_ptr; gcc_jit_field *cast_union_as_lisp_obj; + gcc_jit_field *cast_union_as_lisp_obj_ptr; gcc_jit_function *func; /* Current function being compiled */ gcc_jit_rvalue *most_positive_fixnum; gcc_jit_rvalue *most_negative_fixnum; @@ -340,12 +343,18 @@ type_to_cast_field (gcc_jit_type *type) field = comp.cast_union_as_b; else if (type == comp.void_ptr_type) field = comp.cast_union_as_v_p; + else if (type == comp.uintptr_type) + field = comp.cast_union_as_uintptr; + else if (type == comp.ptrdiff_type) + field = comp.cast_union_as_ptrdiff; else if (type == comp.char_ptr_type) field = comp.cast_union_as_c_p; else if (type == comp.lisp_cons_ptr_type) field = comp.cast_union_as_lisp_cons_ptr; else if (type == comp.lisp_obj_type) field = comp.cast_union_as_lisp_obj; + else if (type == comp.lisp_obj_ptr_type) + field = comp.cast_union_as_lisp_obj_ptr; else error ("unsupported cast\n"); @@ -366,8 +375,8 @@ emit_comment (const char *str) /* reset annotation fields. */ static void -emit_assign_to_stack_slot(basic_block_t *block, stack_el_t *slot, - gcc_jit_rvalue *val) +emit_assign_to_stack_slot (basic_block_t *block, stack_el_t *slot, + gcc_jit_rvalue *val) { gcc_jit_block_add_assignment (block->gcc_bb, NULL, @@ -1366,6 +1375,16 @@ define_cast_union (void) NULL, comp.bool_type, "b"); + comp.cast_union_as_uintptr = + gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.uintptr_type, + "uintptr"); + comp.cast_union_as_ptrdiff = + gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.ptrdiff_type, + "ptrdiff"); comp.cast_union_as_c_p = gcc_jit_context_new_field (comp.ctxt, NULL, @@ -1386,6 +1405,12 @@ define_cast_union (void) NULL, comp.lisp_obj_type, "lisp_obj"); + comp.cast_union_as_lisp_obj_ptr = + gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.lisp_obj_ptr_type, + "lisp_obj_ptr"); + gcc_jit_field *cast_union_fields[] = { comp.cast_union_as_ll, @@ -1395,10 +1420,13 @@ define_cast_union (void) comp.cast_union_as_u, comp.cast_union_as_i, comp.cast_union_as_b, + comp.cast_union_as_uintptr, + comp.cast_union_as_ptrdiff, comp.cast_union_as_c_p, comp.cast_union_as_v_p, comp.cast_union_as_lisp_cons_ptr, - comp.cast_union_as_lisp_obj}; + comp.cast_union_as_lisp_obj, + comp.cast_union_as_lisp_obj_ptr }; comp.cast_union_type = gcc_jit_context_new_union_type (comp.ctxt, NULL, @@ -2170,6 +2198,10 @@ compile_f (const char *lisp_f_name, const char *c_f_name, DECL_AND_SAFE_ALLOCA_BLOCK(push_nargs_check, comp.func); DECL_AND_SAFE_ALLOCA_BLOCK(push_nargs, comp.func); + gcc_jit_rvalue *nargs = + gcc_jit_param_as_rvalue (gcc_jit_function_get_param (comp.func, 0)); + gcc_jit_rvalue *args = + gcc_jit_param_as_rvalue (gcc_jit_function_get_param (comp.func, 1)); gcc_jit_lvalue *i = gcc_jit_function_new_local (comp.func, NULL, comp.ptrdiff_type, commit 0dc882ee2e7e5595f7acfe727975682543354786 Author: Andrea Corallo Date: Tue Jul 2 00:04:03 2019 +0200 add &rest decription diff --git a/src/comp.c b/src/comp.c index 62ce25f63e..970019abe8 100644 --- a/src/comp.c +++ b/src/comp.c @@ -377,6 +377,8 @@ emit_assign_to_stack_slot(basic_block_t *block, stack_el_t *slot, slot->const_set = false; } +/* Declare a function with all args being Lisp_Object and returning a + Lisp_Object. */ static gcc_jit_function * emit_func_declare (const char *f_name, gcc_jit_type *ret_type, @@ -1657,8 +1659,7 @@ define_PSEUDOVECTORP (void) ret_false_b); comp.block = ret_false_b; - gcc_jit_block_end_with_return (ret_false_b->gcc_bb - , + gcc_jit_block_end_with_return (ret_false_b->gcc_bb, NULL, gcc_jit_context_new_rvalue_from_int( comp.ctxt, @@ -2089,10 +2090,34 @@ compile_f (const char *lisp_f_name, const char *c_f_name, } } - eassert (!parse_args); - comp.func = - emit_func_declare (c_f_name, comp.lisp_obj_type, comp_res.max_args, NULL, - GCC_JIT_FUNCTION_EXPORTED, false); + if (!parse_args) + { + comp.func = + emit_func_declare (c_f_name, comp.lisp_obj_type, comp_res.max_args, + NULL, GCC_JIT_FUNCTION_EXPORTED, false); + } + else + { + gcc_jit_param *param[] = + { gcc_jit_context_new_param (comp.ctxt, + NULL, + comp.ptrdiff_type, + "nargs"), + gcc_jit_context_new_param (comp.ctxt, + NULL, + comp.lisp_obj_ptr_type, + "args") }; + comp.func = + gcc_jit_context_new_function (comp.ctxt, + NULL, + GCC_JIT_FUNCTION_EXPORTED, + comp.lisp_obj_type, + c_f_name, + 2, + param, + 0); + } + gcc_jit_lvalue *meta_stack_array = gcc_jit_function_new_local ( @@ -2106,20 +2131,111 @@ compile_f (const char *lisp_f_name, const char *c_f_name, for (int i = 0; i < stack_depth; ++i) stack[i].gcc_lval = gcc_jit_context_new_array_access ( - comp.ctxt, - NULL, - gcc_jit_lvalue_as_rvalue (meta_stack_array), - gcc_jit_context_new_rvalue_from_int (comp.ctxt, - comp.int_type, - i)); + comp.ctxt, + NULL, + gcc_jit_lvalue_as_rvalue (meta_stack_array), + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.int_type, + i)); DECL_AND_SAFE_ALLOCA_BLOCK(prologue, comp.func); basic_block_t *bb_map = compute_blocks (bytestr_length, bytestr_data); - for (ptrdiff_t i = 0; i < comp_res.max_args; ++i) - PUSH_PARAM (gcc_jit_function_get_param (comp.func, i)); - gcc_jit_block_end_with_jump (prologue->gcc_bb, NULL, bb_map[0].gcc_bb); + if (!parse_args) + { + for (ptrdiff_t i = 0; i < comp_res.max_args; ++i) + PUSH_PARAM (gcc_jit_function_get_param (comp.func, i)); + + gcc_jit_block_end_with_jump (prologue->gcc_bb, NULL, bb_map[0].gcc_bb); + } + else + { + /* + nargs will be known at runtime therfore we emit: + + prologue: + i = 0; + push_nargs_check: + if (i < nargs) goto push_args; else goto bb1; + push_nargs: + local[i] = *(args + sizeof (Lisp_Object) * i); + i = i + 1; + goto push_nargs_check; + bb_1: + . + . + . + */ + DECL_AND_SAFE_ALLOCA_BLOCK(push_nargs_check, comp.func); + DECL_AND_SAFE_ALLOCA_BLOCK(push_nargs, comp.func); + + gcc_jit_lvalue *i = gcc_jit_function_new_local (comp.func, + NULL, + comp.ptrdiff_type, + "i"); + gcc_jit_block_add_assignment ( + prologue->gcc_bb, + NULL, + i, + gcc_jit_context_new_rvalue_from_int(comp.ctxt, + comp.ptrdiff_type, + 0)); + + gcc_jit_block_end_with_jump (prologue->gcc_bb, + NULL, + push_nargs_check->gcc_bb); + emit_comparison_jump (GCC_JIT_COMPARISON_LE, + gcc_jit_lvalue_as_rvalue (i), + gcc_jit_param_as_rvalue ( + gcc_jit_function_get_param (comp.func, 0)), /* nargs */ + push_nargs, &bb_map[0]); + gcc_jit_lvalue *arg = + gcc_jit_rvalue_dereference ( + gcc_jit_context_new_binary_op ( + comp.ctxt, + NULL, + GCC_JIT_BINARY_OP_PLUS, + comp.ptrdiff_type, + gcc_jit_param_as_rvalue ( + gcc_jit_function_get_param (comp.func, 1)), /* args */ + gcc_jit_context_new_binary_op ( + comp.ctxt, + NULL, + GCC_JIT_BINARY_OP_MULT, + comp.ptrdiff_type, + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.ptrdiff_type, + sizeof (Lisp_Object)), + gcc_jit_lvalue_as_rvalue (i))), + NULL); + + /* FIXME check side stack values */ + gcc_jit_block_add_assignment ( + push_nargs->gcc_bb, + NULL, + gcc_jit_context_new_array_access ( + comp.ctxt, + NULL, + gcc_jit_lvalue_as_rvalue (meta_stack_array), + gcc_jit_lvalue_as_rvalue (i)), + gcc_jit_lvalue_as_rvalue (arg)); + + gcc_jit_block_add_assignment ( + push_nargs->gcc_bb, + NULL, + i, + gcc_jit_context_new_binary_op (comp.ctxt, + NULL, + GCC_JIT_BINARY_OP_PLUS, + comp.ptrdiff_type, + gcc_jit_lvalue_as_rvalue (i), + comp.one)); + + gcc_jit_block_end_with_jump (push_nargs->gcc_bb, + NULL, + push_nargs_check->gcc_bb); + } comp.block = &bb_map[0]; gcc_jit_rvalue *nil = emit_lisp_obj_from_ptr (Qnil); commit 481062f42e25ea2483593f112794c737698d3d6b Author: Andrea Corallo Date: Mon Jul 1 22:30:08 2019 +0200 introduce parsearg diff --git a/src/comp.c b/src/comp.c index 4d121dc7e6..62ce25f63e 100644 --- a/src/comp.c +++ b/src/comp.c @@ -2053,14 +2053,15 @@ compile_f (const char *lisp_f_name, const char *c_f_name, EMACS_INT stack_depth, Lisp_Object *vectorp, ptrdiff_t vector_size, Lisp_Object args_template) { + USE_SAFE_ALLOCA; gcc_jit_rvalue *res; comp_f_res_t comp_res = { NULL, 0, 0 }; ptrdiff_t pc = 0; gcc_jit_rvalue *args[MAX_POP]; unsigned op; - unsigned pushhandler_n = 0; - - USE_SAFE_ALLOCA; + unsigned pushhandler_n = 0; + comp_res.min_args = 0; + comp_res.max_args = MANY; /* Meta-stack we use to flat the bytecode written for push and pop Emacs VM.*/ @@ -2069,6 +2070,7 @@ compile_f (const char *lisp_f_name, const char *c_f_name, stack = stack_base; stack_over = stack_base + stack_depth; + bool parse_args = true; if (FIXNUMP (args_template)) { ptrdiff_t at = XFIXNUM (args_template); @@ -2081,19 +2083,16 @@ compile_f (const char *lisp_f_name, const char *c_f_name, eassert (!rest); if (!rest && nonrest < SUBR_MAX_ARGS) - comp_res.max_args = nonrest; + { + comp_res.max_args = nonrest; + parse_args = false; + } } - else if (CONSP (args_template)) - /* FIXME */ - comp_res.min_args = comp_res.max_args = XFIXNUM (Flength (args_template)); - - else - eassert (SYMBOLP (args_template) && args_template == Qnil); - - /* Current function being compiled. */ - comp.func = emit_func_declare (c_f_name, comp.lisp_obj_type, comp_res.max_args, - NULL, GCC_JIT_FUNCTION_EXPORTED, false); + eassert (!parse_args); + comp.func = + emit_func_declare (c_f_name, comp.lisp_obj_type, comp_res.max_args, NULL, + GCC_JIT_FUNCTION_EXPORTED, false); gcc_jit_lvalue *meta_stack_array = gcc_jit_function_new_local ( commit 4311d6e04a3131273197d58cedacd150b35c691a Author: Andrea Corallo Date: Mon Jul 1 21:27:52 2019 +0200 introduce MAX_POP diff --git a/src/comp.c b/src/comp.c index d86bd1eb0c..4d121dc7e6 100644 --- a/src/comp.c +++ b/src/comp.c @@ -37,6 +37,10 @@ along with GNU Emacs. If not, see . */ #define MAX_FUN_NAME 256 +/* Max number of entries of the meta-stack that can get poped. */ + +#define MAX_POP 64 + #define DISASS_FILE_NAME "emacs-asm.s" #define CHECK_STACK \ @@ -303,6 +307,7 @@ bcall0 (Lisp_Object f) INLINE static void pop (unsigned n, stack_el_t **stack_ref, gcc_jit_rvalue *args[]) { + eassert (n <= MAX_POP); /* FIXME? */ stack_el_t *stack = *stack_ref; while (n--) @@ -2051,7 +2056,7 @@ compile_f (const char *lisp_f_name, const char *c_f_name, gcc_jit_rvalue *res; comp_f_res_t comp_res = { NULL, 0, 0 }; ptrdiff_t pc = 0; - gcc_jit_rvalue *args[4]; + gcc_jit_rvalue *args[MAX_POP]; unsigned op; unsigned pushhandler_n = 0; @@ -3297,9 +3302,9 @@ DEFUN ("native-compile", Fnative_compile, Snative_compile, opt_level = XFIXNUM (speed); emacs_native_compile (lisp_f_name, c_f_name, func, opt_level, - disassemble != Qnil); + !NILP (disassemble)); - if (disassemble) + if (!NILP (disassemble)) { FILE *fd; Lisp_Object str; commit fac313889774e5e4867788d6f2c58595e8e1604b Author: Andrea Corallo Date: Sun Jun 30 21:01:28 2019 +0200 add comp-tests-ffuncall-lambda-f test diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 42e10ba511..7bd4ddf01c 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -179,7 +179,17 @@ (byte-compile #'comp-tests-ffuncall-apply-many-f) (native-compile #'comp-tests-ffuncall-apply-many-f) - (should (equal (comp-tests-ffuncall-apply-many-f '(1 2 3)) '(1 2 3)))) + (should (equal (comp-tests-ffuncall-apply-many-f '(1 2 3)) '(1 2 3))) + + (defun comp-tests-ffuncall-lambda-f (x) + (let ((fun (lambda (x) + (1+ x)))) + (funcall fun x))) + + (byte-compile #'comp-tests-ffuncall-lambda-f) + (native-compile #'comp-tests-ffuncall-lambda-f) + + (should (= (comp-tests-ffuncall-lambda-f 1) 2))) (ert-deftest comp-tests-conditionals () "Testing conditionals." commit 3fd19aecee00d8ac1b001ed7aebf9c4ff4f36001 Author: Andrea Corallo Date: Sun Jun 30 20:53:59 2019 +0200 fix native call to MANY func diff --git a/src/comp.c b/src/comp.c index 3cd1c3c8db..d86bd1eb0c 100644 --- a/src/comp.c +++ b/src/comp.c @@ -2286,7 +2286,7 @@ compile_f (const char *lisp_f_name, const char *c_f_name, if (stack->const_set && stack->type == Lisp_Symbol) { - ptrdiff_t native_nargs = nargs - 1; + ptrdiff_t native_nargs = op; char *sym_name = (char *) SDATA (SYMBOL_NAME (stack->constant)); if (!strcmp (sym_name, lisp_f_name)) @@ -2304,29 +2304,39 @@ compile_f (const char *lisp_f_name, const char *c_f_name, sym_name)); struct Lisp_Subr *subr = XSUBR ((XSYMBOL (stack->constant)->u.s.function)); - gcc_jit_type *types[native_nargs]; - - for (int i = 0; i < native_nargs; i++) - types[i] = comp.lisp_obj_type; - - gcc_jit_type *fn_ptr_type = - gcc_jit_context_new_function_ptr_type (comp.ctxt, - NULL, - comp.lisp_obj_type, - native_nargs, - types, - 0); - res = - gcc_jit_context_new_call_through_ptr ( - comp.ctxt, - NULL, - gcc_jit_context_new_rvalue_from_ptr (comp.ctxt, - fn_ptr_type, - subr->function.a0), - native_nargs, - args + 1); + if (subr->max_args == MANY) + { + /* FIXME: do we want to optimize this case too? */ + goto dofuncall; + } else + { + gcc_jit_type *types[native_nargs]; + + for (int i = 0; i < native_nargs; i++) + types[i] = comp.lisp_obj_type; + + gcc_jit_type *fn_ptr_type = + gcc_jit_context_new_function_ptr_type ( + comp.ctxt, + NULL, + comp.lisp_obj_type, + native_nargs, + types, + 0); + res = + gcc_jit_context_new_call_through_ptr ( + comp.ctxt, + NULL, + gcc_jit_context_new_rvalue_from_ptr ( + comp.ctxt, + fn_ptr_type, + subr->function.a0), + native_nargs, + args + 1); + } } } + dofuncall: /* Fall back to regular funcall dispatch mechanism. */ if (!res) res = emit_call_n_ref ("Ffuncall", nargs, stack->gcc_lval); diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index afb2a663c0..42e10ba511 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -171,7 +171,15 @@ (byte-compile #'comp-tests-ffuncall-native-f) (native-compile #'comp-tests-ffuncall-native-f) - (should (vectorp (comp-tests-ffuncall-native-f)))) + (should (vectorp (comp-tests-ffuncall-native-f))) + + (defun comp-tests-ffuncall-apply-many-f (x) + (apply #'list x)) + + (byte-compile #'comp-tests-ffuncall-apply-many-f) + (native-compile #'comp-tests-ffuncall-apply-many-f) + + (should (equal (comp-tests-ffuncall-apply-many-f '(1 2 3)) '(1 2 3)))) (ert-deftest comp-tests-conditionals () "Testing conditionals." commit edb0acf2aec0f41832f7ef7d8199ddedb2c3e9d7 Author: Andrea Corallo Date: Sun Jun 30 17:59:04 2019 +0200 fix missing bubble sort test diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 125af64b56..afb2a663c0 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -306,7 +306,7 @@ (error err)) '(wrong-type-argument consp 3)))) -(defun comp-bubble-sort () +(ert-deftest comp-tests-bubble-sort () "Run bubble sort." (defun comp-bubble-sort-f (list) (let ((i (length list))) commit aa312e07b7a9d3e952ccb59abfe9e03dc977217e Author: Andrea Corallo Date: Sun Jun 30 17:42:30 2019 +0200 add primitve call test diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index d2b8f56d36..125af64b56 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -153,15 +153,25 @@ (should (string= (comp-tests-concat-f "bar") "abcdabcabfoobar"))) (ert-deftest comp-tests-ffuncall () - "Testing varset." + "Test calling conventions." (defun comp-tests-ffuncall-callee-f (x y z) (list x y z)) (defun comp-tests-ffuncall-caller-f () (comp-tests-ffuncall-callee-f 1 2 3)) + (byte-compile #'comp-tests-ffuncall-caller-f) (native-compile #'comp-tests-ffuncall-caller-f) - (should (equal (comp-tests-ffuncall-caller-f) '(1 2 3)))) + (should (equal (comp-tests-ffuncall-caller-f) '(1 2 3))) + + (defun comp-tests-ffuncall-native-f () + "Call a primitive with no dedicate op." + (make-vector 1 nil)) + + (byte-compile #'comp-tests-ffuncall-native-f) + (native-compile #'comp-tests-ffuncall-native-f) + + (should (vectorp (comp-tests-ffuncall-native-f)))) (ert-deftest comp-tests-conditionals () "Testing conditionals." commit c4b003f3c8d4a7e508b3f8d72e46829735ffbcbd Author: Andrea Corallo Date: Sun Jun 30 17:23:14 2019 +0200 add emit_assign_to_stack_slot diff --git a/src/comp.c b/src/comp.c index 73a76ea891..3cd1c3c8db 100644 --- a/src/comp.c +++ b/src/comp.c @@ -42,42 +42,31 @@ along with GNU Emacs. If not, see . */ #define CHECK_STACK \ eassert (stack >= stack_base && stack < stack_over) -#define PUSH_LVAL(obj) \ - do { \ - CHECK_STACK; \ - gcc_jit_block_add_assignment (comp.block->gcc_bb, \ - NULL, \ - stack->gcc_lval, \ - gcc_jit_lvalue_as_rvalue(obj)); \ - stack->type = -1; \ - stack->const_set = false; \ - stack++; \ +#define PUSH_LVAL(obj) \ + do { \ + CHECK_STACK; \ + emit_assign_to_stack_slot (comp.block, \ + stack, \ + gcc_jit_lvalue_as_rvalue (obj)); \ + stack++; \ } while (0) -#define PUSH_RVAL(obj) \ - do { \ - CHECK_STACK; \ - gcc_jit_block_add_assignment (comp.block->gcc_bb, \ - NULL, \ - stack->gcc_lval, \ - (obj)); \ - stack->type = -1; \ - stack->const_set = false; \ - stack++; \ +#define PUSH_RVAL(obj) \ + do { \ + CHECK_STACK; \ + emit_assign_to_stack_slot (comp.block, stack, (obj)); \ + stack++; \ } while (0) /* This always happens in the first basic block. */ -#define PUSH_PARAM(obj) \ - do { \ - CHECK_STACK; \ - gcc_jit_block_add_assignment (prologue_bb, \ - NULL, \ - stack->gcc_lval, \ - gcc_jit_param_as_rvalue(obj)); \ - stack->type = -1; \ - stack->const_set = false; \ - stack++; \ +#define PUSH_PARAM(obj) \ + do { \ + CHECK_STACK; \ + emit_assign_to_stack_slot (prologue, \ + stack, \ + gcc_jit_param_as_rvalue (obj)); \ + stack++; \ } while (0) #define TOS (*(stack - 1)) @@ -127,8 +116,8 @@ along with GNU Emacs. If not, see . */ /* With most of the ops we need to do the same stuff so this macros are meant to save some typing. */ -#define CASE(op) \ - case op : \ +#define CASE(op) \ + case op : \ emit_comment (STR(op)) /* Pop from the meta-stack, emit the call and push the result */ @@ -367,6 +356,23 @@ emit_comment (const char *str) str); } + +/* Assignments to the meta-stack slots should be emitted usign this to always */ +/* reset annotation fields. */ + +static void +emit_assign_to_stack_slot(basic_block_t *block, stack_el_t *slot, + gcc_jit_rvalue *val) +{ + gcc_jit_block_add_assignment (block->gcc_bb, + NULL, + slot->gcc_lval, + val); + slot->type = -1; + slot->const_set = false; +} + + static gcc_jit_function * emit_func_declare (const char *f_name, gcc_jit_type *ret_type, unsigned nargs, gcc_jit_rvalue **args, @@ -2103,14 +2109,13 @@ compile_f (const char *lisp_f_name, const char *c_f_name, comp.int_type, i)); - gcc_jit_block *prologue_bb = - gcc_jit_function_new_block (comp.func, "prologue"); + DECL_AND_SAFE_ALLOCA_BLOCK(prologue, comp.func); basic_block_t *bb_map = compute_blocks (bytestr_length, bytestr_data); for (ptrdiff_t i = 0; i < comp_res.max_args; ++i) PUSH_PARAM (gcc_jit_function_get_param (comp.func, i)); - gcc_jit_block_end_with_jump (prologue_bb, NULL, bb_map[0].gcc_bb); + gcc_jit_block_end_with_jump (prologue->gcc_bb, NULL, bb_map[0].gcc_bb); comp.block = &bb_map[0]; gcc_jit_rvalue *nil = emit_lisp_obj_from_ptr (Qnil); @@ -2322,7 +2327,7 @@ compile_f (const char *lisp_f_name, const char *c_f_name, args + 1); } } - /* Fall back to regular funcall dispatch. */ + /* Fall back to regular funcall dispatch mechanism. */ if (!res) res = emit_call_n_ref ("Ffuncall", nargs, stack->gcc_lval); @@ -2438,14 +2443,14 @@ compile_f (const char *lisp_f_name, const char *c_f_name, gcc_jit_rvalue_dereference_field (comp.current_thread, NULL, comp.m_handlerlist); - gcc_jit_block_add_assignment(comp.block->gcc_bb, - NULL, - m_handlerlist, - gcc_jit_lvalue_as_rvalue( - gcc_jit_rvalue_dereference_field ( - gcc_jit_lvalue_as_rvalue (c), - NULL, - comp.handler_next_field))); + gcc_jit_block_add_assignment (comp.block->gcc_bb, + NULL, + m_handlerlist, + gcc_jit_lvalue_as_rvalue( + gcc_jit_rvalue_dereference_field ( + gcc_jit_lvalue_as_rvalue (c), + NULL, + comp.handler_next_field))); /* PUSH (c->val); */ PUSH_LVAL (gcc_jit_rvalue_dereference_field ( gcc_jit_lvalue_as_rvalue (c), @@ -2593,11 +2598,9 @@ compile_f (const char *lisp_f_name, const char *c_f_name, basic_block_t *bb_orig = comp.block; comp.block = sub1_inline_block; - gcc_jit_block_add_assignment (sub1_inline_block->gcc_bb, - NULL, - TOS.gcc_lval, - emit_make_fixnum (sub1_inline_res)); - + emit_assign_to_stack_slot (sub1_inline_block, + &TOS, + emit_make_fixnum (sub1_inline_res)); comp.block = sub1_fcall_block; POP1; res = emit_call ("Fsub1", comp.lisp_obj_type, 1, args); @@ -2652,12 +2655,9 @@ compile_f (const char *lisp_f_name, const char *c_f_name, basic_block_t *bb_orig = comp.block; comp.block = add1_inline_block; - - gcc_jit_block_add_assignment (add1_inline_block->gcc_bb - , - NULL, - TOS.gcc_lval, - emit_make_fixnum (add1_inline_res)); + emit_assign_to_stack_slot(add1_inline_block, + &TOS, + emit_make_fixnum (add1_inline_res)); comp.block = add1_fcall_block; POP1; res = emit_call ("Fadd1", comp.lisp_obj_type, 1, args); @@ -2736,11 +2736,9 @@ compile_f (const char *lisp_f_name, const char *c_f_name, basic_block_t *bb_orig = comp.block; comp.block = negate_inline_block; - gcc_jit_block_add_assignment (negate_inline_block->gcc_bb, - NULL, - TOS.gcc_lval, - emit_make_fixnum (negate_inline_res)); - + emit_assign_to_stack_slot (negate_inline_block, + &TOS, + emit_make_fixnum (negate_inline_res)); comp.block = negate_fcall_block; EMIT_CALL_N_REF ("Fminus", 1); @@ -3113,19 +3111,13 @@ compile_f (const char *lisp_f_name, const char *c_f_name, op = FETCH; POP1; if (op > 0) - gcc_jit_block_add_assignment (comp.block->gcc_bb, - NULL, - (*(stack - op)).gcc_lval, - args[0]); + emit_assign_to_stack_slot (comp.block, stack - op, args[0]); break; CASE (Bstack_set2); op = FETCH2; POP1; - gcc_jit_block_add_assignment (comp.block->gcc_bb, - NULL, - (*(stack - op)).gcc_lval, - args[0]); + emit_assign_to_stack_slot (comp.block, stack - op, args[0]); break; CASE (BdiscardN); @@ -3134,10 +3126,7 @@ compile_f (const char *lisp_f_name, const char *c_f_name, { op &= 0x7F; POP1; - gcc_jit_block_add_assignment (comp.block->gcc_bb, - NULL, - (*(stack - op - 1)).gcc_lval, - args[0]); + emit_assign_to_stack_slot (comp.block, stack - op - 1, args[0]); } DISCARD (op); commit 9e71843f6301cff6e3f0d06e46c47bc5a5c7b177 Author: Andrea Corallo Date: Sun Jun 30 16:10:17 2019 +0200 optimize primitve native call diff --git a/src/comp.c b/src/comp.c index 491fcefe45..73a76ea891 100644 --- a/src/comp.c +++ b/src/comp.c @@ -50,7 +50,7 @@ along with GNU Emacs. If not, see . */ stack->gcc_lval, \ gcc_jit_lvalue_as_rvalue(obj)); \ stack->type = -1; \ - stack->sym_val = NULL; \ + stack->const_set = false; \ stack++; \ } while (0) @@ -62,7 +62,7 @@ along with GNU Emacs. If not, see . */ stack->gcc_lval, \ (obj)); \ stack->type = -1; \ - stack->sym_val = NULL; \ + stack->const_set = false; \ stack++; \ } while (0) @@ -76,7 +76,7 @@ along with GNU Emacs. If not, see . */ stack->gcc_lval, \ gcc_jit_param_as_rvalue(obj)); \ stack->type = -1; \ - stack->sym_val = NULL; \ + stack->const_set = false; \ stack++; \ } while (0) @@ -186,7 +186,8 @@ do { \ typedef struct { gcc_jit_lvalue *gcc_lval; enum Lisp_Type type; /* -1 if not set. */ - char *sym_val; + Lisp_Object constant; /* This is used for constant propagation. */ + bool const_set; } stack_el_t; typedef struct { @@ -2274,22 +2275,57 @@ compile_f (const char *lisp_f_name, const char *c_f_name, op -= Bcall; docall: { + res = NULL; ptrdiff_t nargs = op + 1; pop (nargs, &stack, args); - if (stack->type == Lisp_Symbol && - !strcmp (stack->sym_val, lisp_f_name)) + if (stack->const_set && + stack->type == Lisp_Symbol) { - /* Optimize self calls. */ - res = gcc_jit_context_new_call (comp.ctxt, - NULL, - comp.func, - nargs - 1, - args + 1); - } - else - { - res = emit_call_n_ref ("Ffuncall", nargs, stack->gcc_lval); + ptrdiff_t native_nargs = nargs - 1; + char *sym_name = (char *) SDATA (SYMBOL_NAME (stack->constant)); + if (!strcmp (sym_name, + lisp_f_name)) + { + /* Optimize self calls. */ + res = gcc_jit_context_new_call (comp.ctxt, + NULL, + comp.func, + native_nargs, + args + 1); + } else if (SUBRP ((XSYMBOL (stack->constant)->u.s.function))) + { + /* Optimize primitive native calls. */ + emit_comment (format_string ("Calling primitive %s", + sym_name)); + struct Lisp_Subr *subr = + XSUBR ((XSYMBOL (stack->constant)->u.s.function)); + gcc_jit_type *types[native_nargs]; + + for (int i = 0; i < native_nargs; i++) + types[i] = comp.lisp_obj_type; + + gcc_jit_type *fn_ptr_type = + gcc_jit_context_new_function_ptr_type (comp.ctxt, + NULL, + comp.lisp_obj_type, + native_nargs, + types, + 0); + res = + gcc_jit_context_new_call_through_ptr ( + comp.ctxt, + NULL, + gcc_jit_context_new_rvalue_from_ptr (comp.ctxt, + fn_ptr_type, + subr->function.a0), + native_nargs, + args + 1); + } } + /* Fall back to regular funcall dispatch. */ + if (!res) + res = emit_call_n_ref ("Ffuncall", nargs, stack->gcc_lval); + PUSH_RVAL (res); break; } @@ -3133,9 +3169,12 @@ compile_f (const char *lisp_f_name, const char *c_f_name, PUSH_RVAL (c); TOS.type = XTYPE (vectorp[op]); if (TOS.type == Lisp_Symbol) - /* Store the symbol value for later use is used while - optimizing native and self calls. */ - TOS.sym_val = (char *) SDATA (SYMBOL_NAME (vectorp[op])); + { + /* Store the symbol value for later use is used while + optimizing native and self calls. */ + TOS.constant = vectorp[op]; + TOS.const_set = true; + } break; } commit 5c47cb9600de25a1e8e8e975795480044b866042 Author: Andrea Corallo Date: Sun Jun 30 14:35:41 2019 +0200 propagate contant types and optimize self calls diff --git a/src/comp.c b/src/comp.c index 027090dc6e..491fcefe45 100644 --- a/src/comp.c +++ b/src/comp.c @@ -47,8 +47,10 @@ along with GNU Emacs. If not, see . */ CHECK_STACK; \ gcc_jit_block_add_assignment (comp.block->gcc_bb, \ NULL, \ - (stack)->gcc_lval, \ + stack->gcc_lval, \ gcc_jit_lvalue_as_rvalue(obj)); \ + stack->type = -1; \ + stack->sym_val = NULL; \ stack++; \ } while (0) @@ -57,8 +59,10 @@ along with GNU Emacs. If not, see . */ CHECK_STACK; \ gcc_jit_block_add_assignment (comp.block->gcc_bb, \ NULL, \ - (stack)->gcc_lval, \ + stack->gcc_lval, \ (obj)); \ + stack->type = -1; \ + stack->sym_val = NULL; \ stack++; \ } while (0) @@ -69,8 +73,10 @@ along with GNU Emacs. If not, see . */ CHECK_STACK; \ gcc_jit_block_add_assignment (prologue_bb, \ NULL, \ - (stack)->gcc_lval, \ + stack->gcc_lval, \ gcc_jit_param_as_rvalue(obj)); \ + stack->type = -1; \ + stack->sym_val = NULL; \ stack++; \ } while (0) @@ -84,27 +90,27 @@ along with GNU Emacs. If not, see . */ do { \ stack--; \ CHECK_STACK; \ - args[0] = gcc_jit_lvalue_as_rvalue ((stack)->gcc_lval); \ + args[0] = gcc_jit_lvalue_as_rvalue (stack->gcc_lval); \ } while (0) #define POP2 \ do { \ stack--; \ CHECK_STACK; \ - args[1] = gcc_jit_lvalue_as_rvalue ((stack)->gcc_lval); \ + args[1] = gcc_jit_lvalue_as_rvalue (stack->gcc_lval); \ stack--; \ - args[0] = gcc_jit_lvalue_as_rvalue ((stack)->gcc_lval); \ + args[0] = gcc_jit_lvalue_as_rvalue (stack->gcc_lval); \ } while (0) #define POP3 \ do { \ stack--; \ CHECK_STACK; \ - args[2] = gcc_jit_lvalue_as_rvalue ((stack)->gcc_lval); \ + args[2] = gcc_jit_lvalue_as_rvalue (stack->gcc_lval); \ stack--; \ - args[1] = gcc_jit_lvalue_as_rvalue ((stack)->gcc_lval); \ + args[1] = gcc_jit_lvalue_as_rvalue (stack->gcc_lval); \ stack--; \ - args[0] = gcc_jit_lvalue_as_rvalue ((stack)->gcc_lval); \ + args[0] = gcc_jit_lvalue_as_rvalue (stack->gcc_lval); \ } while (0) /* Fetch the next byte from the bytecode stream. */ @@ -149,7 +155,7 @@ along with GNU Emacs. If not, see . */ #define EMIT_CALL_N_REF(name, nargs) \ do { \ DISCARD (nargs); \ - res = emit_call_n_ref ((name), (nargs), (stack)->gcc_lval); \ + res = emit_call_n_ref ((name), (nargs), stack->gcc_lval); \ PUSH_RVAL (res); \ } while (0) @@ -179,6 +185,8 @@ do { \ /* Element of the meta stack. */ typedef struct { gcc_jit_lvalue *gcc_lval; + enum Lisp_Type type; /* -1 if not set. */ + char *sym_val; } stack_el_t; typedef struct { @@ -2267,8 +2275,21 @@ compile_f (const char *lisp_f_name, const char *c_f_name, docall: { ptrdiff_t nargs = op + 1; - DISCARD (nargs); - res = emit_call_n_ref ("Ffuncall", nargs, stack->gcc_lval); + pop (nargs, &stack, args); + if (stack->type == Lisp_Symbol && + !strcmp (stack->sym_val, lisp_f_name)) + { + /* Optimize self calls. */ + res = gcc_jit_context_new_call (comp.ctxt, + NULL, + comp.func, + nargs - 1, + args + 1); + } + else + { + res = emit_call_n_ref ("Ffuncall", nargs, stack->gcc_lval); + } PUSH_RVAL (res); break; } @@ -3110,6 +3131,11 @@ compile_f (const char *lisp_f_name, const char *c_f_name, gcc_jit_rvalue *c = emit_lisp_obj_from_ptr (vectorp[op]); PUSH_RVAL (c); + TOS.type = XTYPE (vectorp[op]); + if (TOS.type == Lisp_Symbol) + /* Store the symbol value for later use is used while + optimizing native and self calls. */ + TOS.sym_val = (char *) SDATA (SYMBOL_NAME (vectorp[op])); break; } commit 0bdbd4a6012be487e440521e331c6dfc330c2197 Author: Andrea Corallo Date: Sun Jun 30 13:30:49 2019 +0200 introduce stack_el_t diff --git a/src/comp.c b/src/comp.c index fa5b621716..027090dc6e 100644 --- a/src/comp.c +++ b/src/comp.c @@ -47,7 +47,7 @@ along with GNU Emacs. If not, see . */ CHECK_STACK; \ gcc_jit_block_add_assignment (comp.block->gcc_bb, \ NULL, \ - *stack, \ + (stack)->gcc_lval, \ gcc_jit_lvalue_as_rvalue(obj)); \ stack++; \ } while (0) @@ -57,7 +57,7 @@ along with GNU Emacs. If not, see . */ CHECK_STACK; \ gcc_jit_block_add_assignment (comp.block->gcc_bb, \ NULL, \ - *stack, \ + (stack)->gcc_lval, \ (obj)); \ stack++; \ } while (0) @@ -69,7 +69,7 @@ along with GNU Emacs. If not, see . */ CHECK_STACK; \ gcc_jit_block_add_assignment (prologue_bb, \ NULL, \ - *stack, \ + (stack)->gcc_lval, \ gcc_jit_param_as_rvalue(obj)); \ stack++; \ } while (0) @@ -80,31 +80,31 @@ along with GNU Emacs. If not, see . */ #define POP0 -#define POP1 \ - do { \ - stack--; \ - CHECK_STACK; \ - args[0] = gcc_jit_lvalue_as_rvalue (*stack); \ +#define POP1 \ + do { \ + stack--; \ + CHECK_STACK; \ + args[0] = gcc_jit_lvalue_as_rvalue ((stack)->gcc_lval); \ } while (0) -#define POP2 \ - do { \ - stack--; \ - CHECK_STACK; \ - args[1] = gcc_jit_lvalue_as_rvalue (*stack); \ - stack--; \ - args[0] = gcc_jit_lvalue_as_rvalue (*stack); \ +#define POP2 \ + do { \ + stack--; \ + CHECK_STACK; \ + args[1] = gcc_jit_lvalue_as_rvalue ((stack)->gcc_lval); \ + stack--; \ + args[0] = gcc_jit_lvalue_as_rvalue ((stack)->gcc_lval); \ } while (0) -#define POP3 \ - do { \ - stack--; \ - CHECK_STACK; \ - args[2] = gcc_jit_lvalue_as_rvalue (*stack); \ - stack--; \ - args[1] = gcc_jit_lvalue_as_rvalue (*stack); \ - stack--; \ - args[0] = gcc_jit_lvalue_as_rvalue (*stack); \ +#define POP3 \ + do { \ + stack--; \ + CHECK_STACK; \ + args[2] = gcc_jit_lvalue_as_rvalue ((stack)->gcc_lval); \ + stack--; \ + args[1] = gcc_jit_lvalue_as_rvalue ((stack)->gcc_lval); \ + stack--; \ + args[0] = gcc_jit_lvalue_as_rvalue ((stack)->gcc_lval); \ } while (0) /* Fetch the next byte from the bytecode stream. */ @@ -146,11 +146,11 @@ along with GNU Emacs. If not, see . */ This is done by passing a reference to the first obj involved on the stack. */ -#define EMIT_CALL_N_REF(name, nargs) \ - do { \ - DISCARD (nargs); \ - res = emit_call_n_ref ((name), (nargs), *stack); \ - PUSH_RVAL (res); \ +#define EMIT_CALL_N_REF(name, nargs) \ + do { \ + DISCARD (nargs); \ + res = emit_call_n_ref ((name), (nargs), (stack)->gcc_lval); \ + PUSH_RVAL (res); \ } while (0) #define EMIT_ARITHCOMPARE(comparison) \ @@ -176,10 +176,15 @@ do { \ basic_block_t *(name); \ SAFE_ALLOCA_BLOCK ((name), (func), STR(name)) +/* Element of the meta stack. */ +typedef struct { + gcc_jit_lvalue *gcc_lval; +} stack_el_t; + typedef struct { gcc_jit_block *gcc_bb; /* When non zero indicates a stack pointer restart. */ - gcc_jit_lvalue **top; + stack_el_t *top; bool terminated; } basic_block_t; @@ -298,14 +303,14 @@ bcall0 (Lisp_Object f) order. */ INLINE static void -pop (unsigned n, gcc_jit_lvalue ***stack_ref, gcc_jit_rvalue *args[]) +pop (unsigned n, stack_el_t **stack_ref, gcc_jit_rvalue *args[]) { - gcc_jit_lvalue **stack = *stack_ref; + stack_el_t *stack = *stack_ref; while (n--) { stack--; - args[n] = gcc_jit_lvalue_as_rvalue (*stack); + args[n] = gcc_jit_lvalue_as_rvalue (stack->gcc_lval); } *stack_ref = stack; @@ -2039,9 +2044,9 @@ compile_f (const char *lisp_f_name, const char *c_f_name, /* Meta-stack we use to flat the bytecode written for push and pop Emacs VM.*/ - gcc_jit_lvalue **stack_base, **stack, **stack_over; - stack_base = stack = - (gcc_jit_lvalue **) xmalloc (stack_depth * sizeof (gcc_jit_lvalue *)); + stack_el_t *stack_base, *stack, *stack_over; + SAFE_NALLOCA (stack_base, sizeof (stack_el_t), stack_depth); + stack = stack_base; stack_over = stack_base + stack_depth; if (FIXNUMP (args_template)) @@ -2081,13 +2086,13 @@ compile_f (const char *lisp_f_name, const char *c_f_name, "local"); for (int i = 0; i < stack_depth; ++i) - stack[i] = gcc_jit_context_new_array_access ( - comp.ctxt, - NULL, - gcc_jit_lvalue_as_rvalue (meta_stack_array), - gcc_jit_context_new_rvalue_from_int (comp.ctxt, - comp.int_type, - i)); + stack[i].gcc_lval = gcc_jit_context_new_array_access ( + comp.ctxt, + NULL, + gcc_jit_lvalue_as_rvalue (meta_stack_array), + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.int_type, + i)); gcc_jit_block *prologue_bb = gcc_jit_function_new_block (comp.func, "prologue"); @@ -2132,15 +2137,16 @@ compile_f (const char *lisp_f_name, const char *c_f_name, goto stack_ref; CASE (Bstack_ref5); stack_ref: - PUSH_LVAL (stack_base[(stack - stack_base) - (op - Bstack_ref) - 1]); + PUSH_LVAL ( + stack_base[(stack - stack_base) - (op - Bstack_ref) - 1].gcc_lval); break; CASE (Bstack_ref6); - PUSH_LVAL (stack_base[(stack - stack_base) - FETCH - 1]); + PUSH_LVAL (stack_base[(stack - stack_base) - FETCH - 1].gcc_lval); break; CASE (Bstack_ref7); - PUSH_LVAL (stack_base[(stack - stack_base) - FETCH2 - 1]); + PUSH_LVAL (stack_base[(stack - stack_base) - FETCH2 - 1].gcc_lval); break; CASE (Bvarref7); @@ -2262,7 +2268,7 @@ compile_f (const char *lisp_f_name, const char *c_f_name, { ptrdiff_t nargs = op + 1; DISCARD (nargs); - res = emit_call_n_ref ("Ffuncall", nargs, *stack); + res = emit_call_n_ref ("Ffuncall", nargs, stack->gcc_lval); PUSH_RVAL (res); break; } @@ -2365,7 +2371,7 @@ compile_f (const char *lisp_f_name, const char *c_f_name, emit_cond_jump (res, push_h_val_block, &bb_map[pc]); - gcc_jit_lvalue **stack_to_restore = stack; + stack_el_t *stack_to_restore = stack; /* This emit the handler part. */ basic_block_t *bb_orig = comp.block; @@ -2384,10 +2390,10 @@ compile_f (const char *lisp_f_name, const char *c_f_name, NULL, comp.handler_next_field))); /* PUSH (c->val); */ - PUSH_LVAL ( - gcc_jit_rvalue_dereference_field (gcc_jit_lvalue_as_rvalue (c), - NULL, - comp.handler_val_field)); + PUSH_LVAL (gcc_jit_rvalue_dereference_field ( + gcc_jit_lvalue_as_rvalue (c), + NULL, + comp.handler_val_field)); bb_map[handler_pc].top = stack; comp.block = bb_orig; @@ -2501,7 +2507,7 @@ compile_f (const char *lisp_f_name, const char *c_f_name, DECL_AND_SAFE_ALLOCA_BLOCK (sub1_fcall_block, comp.func); gcc_jit_rvalue *tos_as_num = - emit_XFIXNUM (gcc_jit_lvalue_as_rvalue (TOS)); + emit_XFIXNUM (gcc_jit_lvalue_as_rvalue (TOS.gcc_lval)); emit_cond_jump ( gcc_jit_context_new_binary_op ( @@ -2510,7 +2516,7 @@ compile_f (const char *lisp_f_name, const char *c_f_name, GCC_JIT_BINARY_OP_LOGICAL_AND, comp.bool_type, emit_cast (comp.bool_type, - emit_FIXNUMP (gcc_jit_lvalue_as_rvalue (TOS))), + emit_FIXNUMP (gcc_jit_lvalue_as_rvalue (TOS.gcc_lval))), gcc_jit_context_new_comparison (comp.ctxt, NULL, GCC_JIT_COMPARISON_NE, @@ -2532,7 +2538,7 @@ compile_f (const char *lisp_f_name, const char *c_f_name, comp.block = sub1_inline_block; gcc_jit_block_add_assignment (sub1_inline_block->gcc_bb, NULL, - TOS, + TOS.gcc_lval, emit_make_fixnum (sub1_inline_res)); comp.block = sub1_fcall_block; @@ -2561,7 +2567,7 @@ compile_f (const char *lisp_f_name, const char *c_f_name, DECL_AND_SAFE_ALLOCA_BLOCK (add1_fcall_block, comp.func); gcc_jit_rvalue *tos_as_num = - emit_XFIXNUM (gcc_jit_lvalue_as_rvalue (TOS)); + emit_XFIXNUM (gcc_jit_lvalue_as_rvalue (TOS.gcc_lval)); emit_cond_jump ( gcc_jit_context_new_binary_op ( @@ -2570,7 +2576,7 @@ compile_f (const char *lisp_f_name, const char *c_f_name, GCC_JIT_BINARY_OP_LOGICAL_AND, comp.bool_type, emit_cast (comp.bool_type, - emit_FIXNUMP (gcc_jit_lvalue_as_rvalue (TOS))), + emit_FIXNUMP (gcc_jit_lvalue_as_rvalue (TOS.gcc_lval))), gcc_jit_context_new_comparison (comp.ctxt, NULL, GCC_JIT_COMPARISON_NE, @@ -2593,7 +2599,7 @@ compile_f (const char *lisp_f_name, const char *c_f_name, gcc_jit_block_add_assignment (add1_inline_block->gcc_bb , NULL, - TOS, + TOS.gcc_lval, emit_make_fixnum (add1_inline_res)); comp.block = add1_fcall_block; POP1; @@ -2645,7 +2651,7 @@ compile_f (const char *lisp_f_name, const char *c_f_name, DECL_AND_SAFE_ALLOCA_BLOCK (negate_fcall_block, comp.func); gcc_jit_rvalue *tos_as_num = - emit_XFIXNUM (gcc_jit_lvalue_as_rvalue (TOS)); + emit_XFIXNUM (gcc_jit_lvalue_as_rvalue (TOS.gcc_lval)); emit_cond_jump ( gcc_jit_context_new_binary_op ( @@ -2654,7 +2660,7 @@ compile_f (const char *lisp_f_name, const char *c_f_name, GCC_JIT_BINARY_OP_LOGICAL_AND, comp.bool_type, emit_cast (comp.bool_type, - emit_FIXNUMP (gcc_jit_lvalue_as_rvalue (TOS))), + emit_FIXNUMP (gcc_jit_lvalue_as_rvalue (TOS.gcc_lval))), gcc_jit_context_new_comparison (comp.ctxt, NULL, GCC_JIT_COMPARISON_NE, @@ -2675,7 +2681,7 @@ compile_f (const char *lisp_f_name, const char *c_f_name, comp.block = negate_inline_block; gcc_jit_block_add_assignment (negate_inline_block->gcc_bb, NULL, - TOS, + TOS.gcc_lval, emit_make_fixnum (negate_inline_res)); comp.block = negate_fcall_block; @@ -2827,7 +2833,7 @@ compile_f (const char *lisp_f_name, const char *c_f_name, CASE (Bgotoifnilelsepop); op = FETCH2; emit_comparison_jump (GCC_JIT_COMPARISON_EQ, - gcc_jit_lvalue_as_rvalue (TOS), + gcc_jit_lvalue_as_rvalue (TOS.gcc_lval), nil, &bb_map[op], &bb_map[pc]); bb_map[op].top = stack; @@ -2837,7 +2843,7 @@ compile_f (const char *lisp_f_name, const char *c_f_name, CASE (Bgotoifnonnilelsepop); op = FETCH2; emit_comparison_jump (GCC_JIT_COMPARISON_NE, - gcc_jit_lvalue_as_rvalue (TOS), + gcc_jit_lvalue_as_rvalue (TOS.gcc_lval), nil, &bb_map[op], &bb_map[pc]); bb_map[op].top = stack; @@ -2857,7 +2863,7 @@ compile_f (const char *lisp_f_name, const char *c_f_name, break; CASE (Bdup); - PUSH_LVAL (TOS); + PUSH_LVAL (TOS.gcc_lval); break; CASE (Bsave_excursion); @@ -3022,7 +3028,7 @@ compile_f (const char *lisp_f_name, const char *c_f_name, op = FETCH - 128; op += pc; emit_comparison_jump (GCC_JIT_COMPARISON_EQ, - gcc_jit_lvalue_as_rvalue (TOS), + gcc_jit_lvalue_as_rvalue (TOS.gcc_lval), nil, &bb_map[op], &bb_map[pc]); bb_map[op].top = stack; @@ -3033,7 +3039,7 @@ compile_f (const char *lisp_f_name, const char *c_f_name, op = FETCH - 128; op += pc; emit_comparison_jump (GCC_JIT_COMPARISON_NE, - gcc_jit_lvalue_as_rvalue (TOS), + gcc_jit_lvalue_as_rvalue (TOS.gcc_lval), nil, &bb_map[op], &bb_map[pc]); bb_map[op].top = stack; @@ -3052,7 +3058,7 @@ compile_f (const char *lisp_f_name, const char *c_f_name, if (op > 0) gcc_jit_block_add_assignment (comp.block->gcc_bb, NULL, - *(stack - op), + (*(stack - op)).gcc_lval, args[0]); break; @@ -3061,7 +3067,7 @@ compile_f (const char *lisp_f_name, const char *c_f_name, POP1; gcc_jit_block_add_assignment (comp.block->gcc_bb, NULL, - *(stack - op), + (*(stack - op)).gcc_lval, args[0]); break; @@ -3073,7 +3079,7 @@ compile_f (const char *lisp_f_name, const char *c_f_name, POP1; gcc_jit_block_add_assignment (comp.block->gcc_bb, NULL, - *(stack - op - 1), + (*(stack - op - 1)).gcc_lval, args[0]); } @@ -3122,7 +3128,6 @@ compile_f (const char *lisp_f_name, const char *c_f_name, error ("Something went wrong"); exit: - xfree (stack_base); xfree (bb_map); SAFE_FREE (); return comp_res; commit 45c1b64ce68ea4416141d66af07bb24f4fda9930 Author: Andrea Corallo Date: Sun Jun 30 12:07:32 2019 +0200 pass orig lisp f name into compile_f diff --git a/src/comp.c b/src/comp.c index 3f4c0d8aaa..fa5b621716 100644 --- a/src/comp.c +++ b/src/comp.c @@ -2023,8 +2023,8 @@ release_comp (void) } static comp_f_res_t -compile_f (const char *f_name, ptrdiff_t bytestr_length, - unsigned char *bytestr_data, +compile_f (const char *lisp_f_name, const char *c_f_name, + ptrdiff_t bytestr_length, unsigned char *bytestr_data, EMACS_INT stack_depth, Lisp_Object *vectorp, ptrdiff_t vector_size, Lisp_Object args_template) { @@ -2067,7 +2067,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, /* Current function being compiled. */ - comp.func = emit_func_declare (f_name, comp.lisp_obj_type, comp_res.max_args, + comp.func = emit_func_declare (c_f_name, comp.lisp_obj_type, comp_res.max_args, NULL, GCC_JIT_FUNCTION_EXPORTED, false); gcc_jit_lvalue *meta_stack_array = @@ -3157,8 +3157,8 @@ emacs_native_compile (const char *lisp_f_name, const char *c_f_name, sigset_t oldset; block_atimers (&oldset); - comp_f_res_t comp_res = compile_f (c_f_name, bytestr_length, SDATA (bytestr), - XFIXNAT (maxdepth) + 1, + comp_f_res_t comp_res = compile_f (lisp_f_name, c_f_name, bytestr_length, + SDATA (bytestr), XFIXNAT (maxdepth) + 1, vectorp, ASIZE (vector), AREF (func, COMPILED_ARGLIST)); commit 7363e5c24c13c586615c41d92f3fbdf9c207accd Author: Andrea Corallo Date: Sun Jun 30 11:05:02 2019 +0200 rework emit_cond_jump diff --git a/src/comp.c b/src/comp.c index f31be0426f..3f4c0d8aaa 100644 --- a/src/comp.c +++ b/src/comp.c @@ -465,11 +465,26 @@ INLINE static void emit_cond_jump (gcc_jit_rvalue *test, basic_block_t *then_target, basic_block_t *else_target) { - gcc_jit_block_end_with_conditional (comp.block->gcc_bb, + if (gcc_jit_rvalue_get_type (test) == comp.bool_type) + gcc_jit_block_end_with_conditional (comp.block->gcc_bb, NULL, test, then_target->gcc_bb, else_target->gcc_bb); + else + /* In case test is not bool we do a logical negation to obtain a bool as + result. */ + gcc_jit_block_end_with_conditional ( + comp.block->gcc_bb, + NULL, + gcc_jit_context_new_unary_op (comp.ctxt, + NULL, + GCC_JIT_UNARY_OP_LOGICAL_NEGATE, + comp.bool_type, + test), + else_target->gcc_bb, + then_target->gcc_bb); + comp.block->terminated = true; } @@ -1402,9 +1417,7 @@ define_CHECK_TYPE (void) comp.block = init_block; comp.func = comp.check_type; - emit_cond_jump (emit_cast (comp.bool_type, ok), - ok_block, - not_ok_block); + emit_cond_jump (ok, ok_block, not_ok_block); gcc_jit_block_end_with_void_return (ok_block->gcc_bb, NULL); @@ -1470,10 +1483,7 @@ define_CAR_CDR (void) comp.block = init_block; comp.func = f; - emit_cond_jump (emit_cast (comp.bool_type, - emit_CONSP (c)), - is_cons_b, - not_a_cons_b); + emit_cond_jump (emit_CONSP (c), is_cons_b, not_a_cons_b); comp.block = is_cons_b; @@ -1491,9 +1501,7 @@ define_CAR_CDR (void) DECL_AND_SAFE_ALLOCA_BLOCK (is_nil_b, f); DECL_AND_SAFE_ALLOCA_BLOCK (not_nil_b, f); - emit_cond_jump (emit_NILP (c), - is_nil_b, - not_nil_b); + emit_cond_jump (emit_NILP (c), is_nil_b, not_nil_b); comp.block = is_nil_b; gcc_jit_block_end_with_return (comp.block->gcc_bb, @@ -1619,11 +1627,9 @@ define_PSEUDOVECTORP (void) comp.block = init_block; comp.func = comp.pseudovectorp; - emit_cond_jump ( - emit_cast (comp.bool_type, - emit_VECTORLIKEP (gcc_jit_param_as_rvalue (param[0]))), - call_pseudovector_typep_b, - ret_false_b); + emit_cond_jump (emit_VECTORLIKEP (gcc_jit_param_as_rvalue (param[0])), + call_pseudovector_typep_b, + ret_false_b); comp.block = ret_false_b; gcc_jit_block_end_with_return (ret_false_b->gcc_bb @@ -1680,8 +1686,8 @@ define_CHECK_IMPURE (void) comp.func = comp.check_impure; emit_cond_jump (emit_PURE_P (gcc_jit_param_as_rvalue (param[0])), /* FIXME */ - err_block, - ok_block); + err_block, + ok_block); gcc_jit_block_end_with_void_return (ok_block->gcc_bb, NULL); gcc_jit_rvalue *pure_write_error_arg = @@ -2356,15 +2362,8 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, comp.func, format_string ("push_h_val_%u", pushhandler_n)); - emit_cond_jump ( - /* This negation is just to have a bool. */ - gcc_jit_context_new_unary_op (comp.ctxt, - NULL, - GCC_JIT_UNARY_OP_LOGICAL_NEGATE, - comp.bool_type, - res), - &bb_map[pc], - push_h_val_block); + + emit_cond_jump (res, push_h_val_block, &bb_map[pc]); gcc_jit_lvalue **stack_to_restore = stack; /* This emit the handler part. */ commit dc963cf0c8a6f009bc3f2ddbb8224b57ded53339 Author: Andrea Corallo Date: Sun Jun 30 10:42:13 2019 +0200 inline setcdr support diff --git a/src/comp.c b/src/comp.c index 538169c0b2..f31be0426f 100644 --- a/src/comp.c +++ b/src/comp.c @@ -254,6 +254,7 @@ typedef struct { gcc_jit_function *car; gcc_jit_function *cdr; gcc_jit_function *setcar; + gcc_jit_function *setcdr; gcc_jit_function *check_type; gcc_jit_function *check_impure; basic_block_t *block; /* Current basic block */ @@ -918,6 +919,31 @@ emit_XCDR (gcc_jit_rvalue *c) comp.lisp_cons_u_s_u_cdr); } +static gcc_jit_lvalue * +emit_lval_XCDR (gcc_jit_rvalue *c) +{ + emit_comment ("lval_XCDR"); + + /* XCONS (c)->u.s.u.cdr */ + return + gcc_jit_lvalue_access_field ( + /* XCONS (c)->u.s.u */ + gcc_jit_lvalue_access_field ( + /* XCONS (c)->u.s */ + gcc_jit_lvalue_access_field ( + /* XCONS (c)->u */ + gcc_jit_rvalue_dereference_field ( + emit_XCONS (c), + NULL, + comp.lisp_cons_u), + NULL, + comp.lisp_cons_u_s), + NULL, + comp.lisp_cons_u_s_u), + NULL, + comp.lisp_cons_u_s_u_cdr); +} + static void emit_CHECK_CONS (gcc_jit_rvalue *x) { @@ -946,6 +972,14 @@ emit_car_addr (gcc_jit_rvalue *c) return gcc_jit_lvalue_get_address (emit_lval_XCAR (c), NULL); } +static gcc_jit_rvalue * +emit_cdr_addr (gcc_jit_rvalue *c) +{ + emit_comment ("cdr_addr"); + + return gcc_jit_lvalue_get_address (emit_lval_XCDR (c), NULL); +} + static void emit_XSETCAR (gcc_jit_rvalue *c, gcc_jit_rvalue *n) { @@ -960,6 +994,20 @@ emit_XSETCAR (gcc_jit_rvalue *c, gcc_jit_rvalue *n) n); } +static void +emit_XSETCDR (gcc_jit_rvalue *c, gcc_jit_rvalue *n) +{ + emit_comment ("XSETCDR"); + + gcc_jit_block_add_assignment( + comp.block->gcc_bb, + NULL, + gcc_jit_rvalue_dereference ( + emit_cdr_addr (c), + NULL), + n); +} + static gcc_jit_rvalue * emit_PURE_P (gcc_jit_rvalue *ptr) { @@ -1471,62 +1519,73 @@ define_CAR_CDR (void) } static void -define_setcar (void) +define_setcar_setcdr (void) { USE_SAFE_ALLOCA; - gcc_jit_param *cell = - gcc_jit_context_new_param (comp.ctxt, - NULL, - comp.lisp_obj_type, - "cell"); - gcc_jit_param *new_car = - gcc_jit_context_new_param (comp.ctxt, - NULL, - comp.lisp_obj_type, - "new_car"); - - gcc_jit_param *param[] = { cell, new_car }; - comp.setcar = - gcc_jit_context_new_function (comp.ctxt, NULL, - GCC_JIT_FUNCTION_ALWAYS_INLINE, - comp.lisp_obj_type, - "setcar", - 2, - param, - 0); + char const *f_name[] = {"setcar", "setcdr"}; + char const *par_name[] = {"new_car", "new_cdr"}; - DECL_AND_SAFE_ALLOCA_BLOCK (init_block, comp.setcar); - comp.block = init_block; - comp.func = comp.setcar; + for (int i = 0; i < 2; i++) + { + gcc_jit_param *cell = + gcc_jit_context_new_param (comp.ctxt, + NULL, + comp.lisp_obj_type, + "cell"); + gcc_jit_param *new_el = + gcc_jit_context_new_param (comp.ctxt, + NULL, + comp.lisp_obj_type, + par_name[i]); + + gcc_jit_param *param[] = { cell, new_el }; + + gcc_jit_function **f_ref = !i ? &comp.setcar : &comp.setcdr; + *f_ref = gcc_jit_context_new_function (comp.ctxt, NULL, + GCC_JIT_FUNCTION_ALWAYS_INLINE, + comp.lisp_obj_type, + f_name[i], + 2, + param, + 0); + DECL_AND_SAFE_ALLOCA_BLOCK (init_block, *f_ref); + comp.func = *f_ref; + comp.block = init_block; - /* CHECK_CONS (cell); */ - emit_CHECK_CONS (gcc_jit_param_as_rvalue (cell)); + /* CHECK_CONS (cell); */ + emit_CHECK_CONS (gcc_jit_param_as_rvalue (cell)); - /* CHECK_IMPURE (cell, XCONS (cell)); */ - gcc_jit_rvalue *args[] = - { gcc_jit_param_as_rvalue (cell), - emit_XCONS (gcc_jit_param_as_rvalue (cell)) }; + /* CHECK_IMPURE (cell, XCONS (cell)); */ + gcc_jit_rvalue *args[] = + { gcc_jit_param_as_rvalue (cell), + emit_XCONS (gcc_jit_param_as_rvalue (cell)) }; - gcc_jit_block_add_eval ( - init_block->gcc_bb, - NULL, - gcc_jit_context_new_call (comp.ctxt, + gcc_jit_block_add_eval ( + init_block->gcc_bb, NULL, - comp.check_impure, - 2, - args)); - - /* XSETCAR (cell, newcar); */ - emit_XSETCAR (gcc_jit_param_as_rvalue (cell), - gcc_jit_param_as_rvalue (new_car)); + gcc_jit_context_new_call (comp.ctxt, + NULL, + comp.check_impure, + 2, + args)); + + /* XSETCDR (cell, newel); */ + if (!i) + emit_XSETCAR (gcc_jit_param_as_rvalue (cell), + gcc_jit_param_as_rvalue (new_el)); + else + emit_XSETCDR (gcc_jit_param_as_rvalue (cell), + gcc_jit_param_as_rvalue (new_el)); - /* return newcar; */ - gcc_jit_block_end_with_return (init_block->gcc_bb, - NULL, - gcc_jit_param_as_rvalue (new_car)); + /* return newel; */ + gcc_jit_block_end_with_return (init_block->gcc_bb, + NULL, + gcc_jit_param_as_rvalue (new_el)); + } SAFE_FREE (); } + /* Declare a substitute for PSEUDOVECTORP as always inlined function. */ static void @@ -1942,7 +2001,7 @@ init_comp (int opt_level) define_CHECK_TYPE (); define_CHECK_IMPURE (); define_bool_to_lisp_obj (); - define_setcar(); + define_setcar_setcdr(); } static void @@ -2885,7 +2944,14 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, PUSH_RVAL (res); break; - CASE_CALL_N (setcdr, 2); + case Bsetcdr: + POP2; + res = gcc_jit_context_new_call (comp.ctxt, + NULL, + comp.setcdr, + 2, args); + PUSH_RVAL (res); + break; CASE (Bcar_safe); EMIT_CALL_N ("CAR_SAFE", 1); diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 47c61c82bd..d2b8f56d36 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -289,6 +289,11 @@ err (comp-tests-setcar-f 3 10) (error err)) + '(wrong-type-argument consp 3))) + (should (equal (condition-case + err + (comp-tests-setcdr-f 3 10) + (error err)) '(wrong-type-argument consp 3)))) (defun comp-bubble-sort () commit b5b0e63bbc23a6584e5aaa49861a37b832a0def3 Author: Andrea Corallo Date: Sun Jun 30 10:11:39 2019 +0200 fix setcar diff --git a/src/comp.c b/src/comp.c index 4973a517d6..538169c0b2 100644 --- a/src/comp.c +++ b/src/comp.c @@ -657,7 +657,7 @@ emit_VECTORLIKEP (gcc_jit_rvalue *obj) static gcc_jit_rvalue * emit_CONSP (gcc_jit_rvalue *obj) { - emit_comment ("CONSP"); + emit_comment ("CONSP"); return emit_TAGGEDP (obj, Lisp_Cons); } @@ -928,11 +928,14 @@ emit_CHECK_CONS (gcc_jit_rvalue *x) emit_lisp_obj_from_ptr (Qconsp), x }; - gcc_jit_context_new_call (comp.ctxt, - NULL, - comp.check_type, - 3, - args); + gcc_jit_block_add_eval ( + comp.block->gcc_bb, + NULL, + gcc_jit_context_new_call (comp.ctxt, + NULL, + comp.check_type, + 3, + args)); } static gcc_jit_rvalue * @@ -1497,11 +1500,28 @@ define_setcar (void) comp.block = init_block; comp.func = comp.setcar; + /* CHECK_CONS (cell); */ emit_CHECK_CONS (gcc_jit_param_as_rvalue (cell)); + /* CHECK_IMPURE (cell, XCONS (cell)); */ + gcc_jit_rvalue *args[] = + { gcc_jit_param_as_rvalue (cell), + emit_XCONS (gcc_jit_param_as_rvalue (cell)) }; + + gcc_jit_block_add_eval ( + init_block->gcc_bb, + NULL, + gcc_jit_context_new_call (comp.ctxt, + NULL, + comp.check_impure, + 2, + args)); + + /* XSETCAR (cell, newcar); */ emit_XSETCAR (gcc_jit_param_as_rvalue (cell), gcc_jit_param_as_rvalue (new_car)); + /* return newcar; */ gcc_jit_block_end_with_return (init_block->gcc_bb, NULL, gcc_jit_param_as_rvalue (new_car)); @@ -1600,9 +1620,7 @@ define_CHECK_IMPURE (void) comp.block = init_block; comp.func = comp.check_impure; - emit_cond_jump ( - emit_cast (comp.bool_type, - emit_PURE_P (gcc_jit_param_as_rvalue (param[0]))), /* FIXME */ + emit_cond_jump (emit_PURE_P (gcc_jit_param_as_rvalue (param[0])), /* FIXME */ err_block, ok_block); gcc_jit_block_end_with_void_return (ok_block->gcc_bb, NULL); diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 8fd3ca2e19..47c61c82bd 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -284,7 +284,12 @@ (native-compile #'comp-tests-setcdr-f) (should (equal (comp-tests-setcar-f '(10 . 10) 3) '(3 . 10))) - (should (equal (comp-tests-setcdr-f '(10 . 10) 3) '(10 . 3)))) + (should (equal (comp-tests-setcdr-f '(10 . 10) 3) '(10 . 3))) + (should (equal (condition-case + err + (comp-tests-setcar-f 3 10) + (error err)) + '(wrong-type-argument consp 3)))) (defun comp-bubble-sort () "Run bubble sort." commit 58dfd08fed075df5b0e8b059716b3e3638eafce9 Author: Andrea Corallo Date: Sat Jun 29 16:44:06 2019 +0200 reworking blocks diff --git a/src/comp.c b/src/comp.c index 5be5fa51d3..4973a517d6 100644 --- a/src/comp.c +++ b/src/comp.c @@ -130,7 +130,7 @@ along with GNU Emacs. If not, see . */ #define EMIT_CALL_N(name, nargs) \ do { \ POP##nargs; \ - res = emit_call (name, comp.lisp_obj_type, nargs, args); \ + res = emit_call ((name), comp.lisp_obj_type, (nargs), args); \ PUSH_RVAL (res); \ } while (0) @@ -149,7 +149,7 @@ along with GNU Emacs. If not, see . */ #define EMIT_CALL_N_REF(name, nargs) \ do { \ DISCARD (nargs); \ - res = emit_call_n_ref (name, nargs, *stack); \ + res = emit_call_n_ref ((name), (nargs), *stack); \ PUSH_RVAL (res); \ } while (0) @@ -158,11 +158,24 @@ along with GNU Emacs. If not, see . */ POP2; \ args[2] = gcc_jit_context_new_rvalue_from_int (comp.ctxt, \ comp.int_type, \ - comparison); \ + (comparison)); \ res = emit_call ("arithcompare", comp.lisp_obj_type, 3, args); \ PUSH_RVAL (res); \ } while (0) + +#define SAFE_ALLOCA_BLOCK(ptr, func, name) \ +do { \ + (ptr) = SAFE_ALLOCA (sizeof (basic_block_t)); \ + (ptr)->gcc_bb = gcc_jit_function_new_block ((func), (name)); \ + (ptr)->terminated = false; \ + (ptr)->top = NULL; \ + } while (0) + +#define DECL_AND_SAFE_ALLOCA_BLOCK(name, func) \ + basic_block_t *(name); \ + SAFE_ALLOCA_BLOCK ((name), (func), STR(name)) + typedef struct { gcc_jit_block *gcc_bb; /* When non zero indicates a stack pointer restart. */ @@ -261,7 +274,6 @@ typedef struct { void emacs_native_compile (const char *lisp_f_name, const char *c_f_name, Lisp_Object func, int opt_level, bool dump_asm); - static char * ATTRIBUTE_FORMAT_PRINTF (1, 2) format_string (const char *format, ...) { @@ -450,22 +462,22 @@ emit_call (const char *f_name, gcc_jit_type *ret_type, unsigned nargs, INLINE static void emit_cond_jump (gcc_jit_rvalue *test, - gcc_jit_block *then_target, gcc_jit_block *else_target) + basic_block_t *then_target, basic_block_t *else_target) { gcc_jit_block_end_with_conditional (comp.block->gcc_bb, NULL, test, - then_target, - else_target); + then_target->gcc_bb, + else_target->gcc_bb); comp.block->terminated = true; } /* Close current basic block emitting a comparison between two rval. */ static gcc_jit_rvalue * -emit_comparison_jump (enum gcc_jit_comparison op, /* TODO add basick block as param */ +emit_comparison_jump (enum gcc_jit_comparison op, gcc_jit_rvalue *a, gcc_jit_rvalue *b, - gcc_jit_block *then_target, gcc_jit_block *else_target) + basic_block_t *then_target, basic_block_t *else_target) { gcc_jit_rvalue *test = gcc_jit_context_new_comparison (comp.ctxt, NULL, @@ -768,7 +780,7 @@ emit_NUMBERP (gcc_jit_rvalue *obj) } static gcc_jit_rvalue * -emit_make_fixnum (gcc_jit_block *block, gcc_jit_rvalue *obj) +emit_make_fixnum (gcc_jit_rvalue *obj) { emit_comment ("make_fixnum"); @@ -792,7 +804,7 @@ emit_make_fixnum (gcc_jit_block *block, gcc_jit_rvalue *obj) comp.lisp_obj_type, "lisp_obj_fixnum"); - gcc_jit_block_add_assignment (block, + gcc_jit_block_add_assignment (comp.block->gcc_bb, NULL, emit_lval_XLI (res), tmp); @@ -801,13 +813,10 @@ emit_make_fixnum (gcc_jit_block *block, gcc_jit_rvalue *obj) } /* Construct fill and return a lisp object form a raw pointer. */ -/* FIXME do not pass bb */ static gcc_jit_rvalue * -emit_lisp_obj_from_ptr (basic_block_t *block, void *p) +emit_lisp_obj_from_ptr (void *p) { static unsigned i; - - comp.block = block; emit_comment ("lisp_obj_from_ptr"); gcc_jit_lvalue *lisp_obj = @@ -825,10 +834,11 @@ emit_lisp_obj_from_ptr (basic_block_t *block, void *p) format_string ("Symbol %s", (char *) SDATA (SYMBOL_NAME (p)))); - gcc_jit_block_add_assignment (block->gcc_bb, + gcc_jit_block_add_assignment (comp.block->gcc_bb, NULL, emit_lval_XLP (lisp_obj), void_ptr); + return gcc_jit_lvalue_as_rvalue (lisp_obj); } @@ -837,7 +847,7 @@ emit_NILP (gcc_jit_rvalue *x) { emit_comment ("NILP"); - return emit_EQ (x, emit_lisp_obj_from_ptr (comp.block, Qnil)); + return emit_EQ (x, emit_lisp_obj_from_ptr (Qnil)); } static gcc_jit_rvalue * @@ -915,10 +925,9 @@ emit_CHECK_CONS (gcc_jit_rvalue *x) gcc_jit_rvalue *args[] = { emit_CONSP (x), - emit_lisp_obj_from_ptr (comp.block, Qconsp), + emit_lisp_obj_from_ptr (Qconsp), x }; - gcc_jit_context_new_call (comp.ctxt, NULL, comp.check_type, @@ -1309,6 +1318,7 @@ define_cast_union (void) static void define_CHECK_TYPE (void) { + USE_SAFE_ALLOCA; gcc_jit_param *param[] = { gcc_jit_context_new_param (comp.ctxt, NULL, @@ -1334,26 +1344,20 @@ define_CHECK_TYPE (void) gcc_jit_rvalue *predicate = gcc_jit_param_as_rvalue (param[1]); gcc_jit_rvalue *x = gcc_jit_param_as_rvalue (param[2]); - gcc_jit_block *initial_block = - gcc_jit_function_new_block (comp.check_type, "initial_block"); - gcc_jit_block *ok_block = - gcc_jit_function_new_block (comp.check_type, "ok_block"); - gcc_jit_block *not_ok_block = - gcc_jit_function_new_block (comp.check_type, "not_ok_block"); - - /* Set current context as needed */ - basic_block_t block = { .gcc_bb = initial_block, - .terminated = false }; - comp.block = █ + DECL_AND_SAFE_ALLOCA_BLOCK (init_block, comp.check_type); + DECL_AND_SAFE_ALLOCA_BLOCK (ok_block, comp.check_type); + DECL_AND_SAFE_ALLOCA_BLOCK (not_ok_block, comp.check_type); + + comp.block = init_block; comp.func = comp.check_type; emit_cond_jump (emit_cast (comp.bool_type, ok), ok_block, not_ok_block); - gcc_jit_block_end_with_void_return (ok_block, NULL); + gcc_jit_block_end_with_void_return (ok_block->gcc_bb, NULL); - comp.block->gcc_bb = not_ok_block; + comp.block = not_ok_block; gcc_jit_rvalue *wrong_type_args[] = { predicate, x }; @@ -1362,7 +1366,9 @@ define_CHECK_TYPE (void) emit_call ("wrong_type_argument", comp.lisp_obj_type, 2, wrong_type_args)); - gcc_jit_block_end_with_void_return (not_ok_block, NULL); + gcc_jit_block_end_with_void_return (not_ok_block->gcc_bb, NULL); + + SAFE_FREE (); } @@ -1371,6 +1377,8 @@ define_CHECK_TYPE (void) static void define_CAR_CDR (void) { + USE_SAFE_ALLOCA; + gcc_jit_param *car_param = gcc_jit_context_new_param (comp.ctxt, NULL, @@ -1404,20 +1412,11 @@ define_CAR_CDR (void) for (int i = 0; i < 2; i++) { gcc_jit_rvalue *c = gcc_jit_param_as_rvalue (param); - gcc_jit_block *initial_block = - gcc_jit_function_new_block (f, "initial_block"); + DECL_AND_SAFE_ALLOCA_BLOCK (init_block, f); + DECL_AND_SAFE_ALLOCA_BLOCK (is_cons_b, f); + DECL_AND_SAFE_ALLOCA_BLOCK (not_a_cons_b, f); - gcc_jit_block *is_cons_b = - gcc_jit_function_new_block (f, "is_cons"); - - gcc_jit_block *not_a_cons_b = - gcc_jit_function_new_block (f, "not_a_cons"); - - - /* Set current context as needed */ - basic_block_t block = { .gcc_bb = initial_block, - .terminated = false }; - comp.block = █ + comp.block = init_block; comp.func = f; emit_cond_jump (emit_cast (comp.bool_type, @@ -1425,7 +1424,7 @@ define_CAR_CDR (void) is_cons_b, not_a_cons_b); - comp.block->gcc_bb = is_cons_b; + comp.block = is_cons_b; if (f == comp.car) gcc_jit_block_end_with_return (comp.block->gcc_bb, @@ -1436,25 +1435,23 @@ define_CAR_CDR (void) NULL, emit_XCDR (c)); - comp.block->gcc_bb = not_a_cons_b; + comp.block = not_a_cons_b; - gcc_jit_block *is_nil_b = - gcc_jit_function_new_block (f, "is_nil"); - gcc_jit_block *not_nil_b = - gcc_jit_function_new_block (f, "not_nil"); + DECL_AND_SAFE_ALLOCA_BLOCK (is_nil_b, f); + DECL_AND_SAFE_ALLOCA_BLOCK (not_nil_b, f); emit_cond_jump (emit_NILP (c), is_nil_b, not_nil_b); - comp.block->gcc_bb = is_nil_b; + comp.block = is_nil_b; gcc_jit_block_end_with_return (comp.block->gcc_bb, NULL, - emit_lisp_obj_from_ptr (comp.block, Qnil)); + emit_lisp_obj_from_ptr (Qnil)); - comp.block->gcc_bb = not_nil_b; + comp.block = not_nil_b; gcc_jit_rvalue *wrong_type_args[] = - { emit_lisp_obj_from_ptr (comp.block, Qlistp), c }; + { emit_lisp_obj_from_ptr (Qlistp), c }; gcc_jit_block_add_eval (comp.block->gcc_bb, NULL, @@ -1462,15 +1459,18 @@ define_CAR_CDR (void) comp.lisp_obj_type, 2, wrong_type_args)); gcc_jit_block_end_with_return (comp.block->gcc_bb, NULL, - emit_lisp_obj_from_ptr (comp.block, Qnil)); + emit_lisp_obj_from_ptr (Qnil)); f = comp.cdr; param = cdr_param; } + + SAFE_FREE (); } static void define_setcar (void) { + USE_SAFE_ALLOCA; gcc_jit_param *cell = gcc_jit_context_new_param (comp.ctxt, @@ -1492,12 +1492,9 @@ define_setcar (void) 2, param, 0); - gcc_jit_block *initial_block = - gcc_jit_function_new_block (comp.setcar, "initial_block"); - /* Set current context as needed */ - basic_block_t block = { .gcc_bb = initial_block, - .terminated = false }; - comp.block = █ + + DECL_AND_SAFE_ALLOCA_BLOCK (init_block, comp.setcar); + comp.block = init_block; comp.func = comp.setcar; emit_CHECK_CONS (gcc_jit_param_as_rvalue (cell)); @@ -1505,16 +1502,18 @@ define_setcar (void) emit_XSETCAR (gcc_jit_param_as_rvalue (cell), gcc_jit_param_as_rvalue (new_car)); - gcc_jit_block_end_with_return (initial_block, + gcc_jit_block_end_with_return (init_block->gcc_bb, NULL, gcc_jit_param_as_rvalue (new_car)); - + SAFE_FREE (); } /* Declare a substitute for PSEUDOVECTORP as always inlined function. */ static void define_PSEUDOVECTORP (void) { + USE_SAFE_ALLOCA; + gcc_jit_param *param[] = { gcc_jit_context_new_param (comp.ctxt, NULL, @@ -1534,19 +1533,11 @@ define_PSEUDOVECTORP (void) param, 0); - gcc_jit_block *initial_block = - gcc_jit_function_new_block (comp.pseudovectorp, "initial_block"); - - gcc_jit_block *ret_false_b = - gcc_jit_function_new_block (comp.pseudovectorp, "ret_false"); - - gcc_jit_block *call_pseudovector_typep_b = - gcc_jit_function_new_block (comp.pseudovectorp, "call_pseudovector"); + DECL_AND_SAFE_ALLOCA_BLOCK (init_block, comp.pseudovectorp); + DECL_AND_SAFE_ALLOCA_BLOCK (ret_false_b, comp.pseudovectorp); + DECL_AND_SAFE_ALLOCA_BLOCK (call_pseudovector_typep_b, comp.pseudovectorp); - /* Set current context as needed */ - basic_block_t block = { .gcc_bb = initial_block, - .terminated = false }; - comp.block = █ + comp.block = init_block; comp.func = comp.pseudovectorp; emit_cond_jump ( @@ -1555,8 +1546,9 @@ define_PSEUDOVECTORP (void) call_pseudovector_typep_b, ret_false_b); - comp.block->gcc_bb = ret_false_b; - gcc_jit_block_end_with_return (ret_false_b, + comp.block = ret_false_b; + gcc_jit_block_end_with_return (ret_false_b->gcc_bb + , NULL, gcc_jit_context_new_rvalue_from_int( comp.ctxt, @@ -1566,19 +1558,23 @@ define_PSEUDOVECTORP (void) gcc_jit_rvalue *args[2] = { gcc_jit_param_as_rvalue (param[0]), gcc_jit_param_as_rvalue (param[1]) }; - comp.block->gcc_bb = call_pseudovector_typep_b; + comp.block = call_pseudovector_typep_b; /* FIXME use XUNTAG now that's available. */ - gcc_jit_block_end_with_return (call_pseudovector_typep_b, + gcc_jit_block_end_with_return (call_pseudovector_typep_b->gcc_bb + , NULL, emit_call ("helper_PSEUDOVECTOR_TYPEP_XUNTAG", comp.bool_type, 2, args)); + SAFE_FREE (); } static void define_CHECK_IMPURE (void) { + USE_SAFE_ALLOCA; + gcc_jit_param *param[] = { gcc_jit_context_new_param (comp.ctxt, NULL, @@ -1596,46 +1592,42 @@ define_CHECK_IMPURE (void) 2, param, 0); - gcc_jit_block *initial_block = - gcc_jit_function_new_block (comp.check_impure, - "initial_block"); - gcc_jit_block *err_block = - gcc_jit_function_new_block (comp.check_impure, - "err_block"); - gcc_jit_block *ok_block = - gcc_jit_function_new_block (comp.check_impure, - "ok_block"); - - /* Set current context as needed */ - basic_block_t block = { .gcc_bb = initial_block, - .terminated = false }; - comp.block = █ + + DECL_AND_SAFE_ALLOCA_BLOCK (init_block, comp.check_impure); + DECL_AND_SAFE_ALLOCA_BLOCK (err_block, comp.check_impure); + DECL_AND_SAFE_ALLOCA_BLOCK (ok_block, comp.check_impure); + + comp.block = init_block; comp.func = comp.check_impure; - emit_cond_jump (emit_cast (comp.bool_type, - emit_PURE_P (gcc_jit_param_as_rvalue (param[0]))), /* FIXME */ - err_block, - ok_block); - gcc_jit_block_end_with_void_return (ok_block, NULL); + emit_cond_jump ( + emit_cast (comp.bool_type, + emit_PURE_P (gcc_jit_param_as_rvalue (param[0]))), /* FIXME */ + err_block, + ok_block); + gcc_jit_block_end_with_void_return (ok_block->gcc_bb, NULL); gcc_jit_rvalue *pure_write_error_arg = gcc_jit_param_as_rvalue (param[0]); - comp.block->gcc_bb = err_block; + comp.block = err_block; gcc_jit_block_add_eval (comp.block->gcc_bb, NULL, emit_call ("pure_write_error", comp.void_type, 1, &pure_write_error_arg)); - gcc_jit_block_end_with_void_return (err_block, NULL); -} + gcc_jit_block_end_with_void_return (err_block->gcc_bb, NULL); + + SAFE_FREE ();} /* Declare a function to convert boolean into t or nil */ static void define_bool_to_lisp_obj (void) { + USE_SAFE_ALLOCA; + /* x ? Qt : Qnil */ gcc_jit_param *param = gcc_jit_context_new_param (comp.ctxt, NULL, @@ -1649,32 +1641,27 @@ define_bool_to_lisp_obj (void) 1, ¶m, 0); - gcc_jit_block *initial_block = - gcc_jit_function_new_block (comp.bool_to_lisp_obj, - "bool_to_lisp_obj_initial_block"); - gcc_jit_block *ret_t_block = - gcc_jit_function_new_block (comp.bool_to_lisp_obj, - "ret_t"); - gcc_jit_block *ret_nil_block = - gcc_jit_function_new_block (comp.bool_to_lisp_obj, - "ret_nil"); - /* Set current context as needed */ - basic_block_t block = { .gcc_bb = initial_block, - .terminated = false }; - comp.block = █ + DECL_AND_SAFE_ALLOCA_BLOCK (init_block, comp.bool_to_lisp_obj); + DECL_AND_SAFE_ALLOCA_BLOCK (ret_t_block, comp.bool_to_lisp_obj); + DECL_AND_SAFE_ALLOCA_BLOCK (ret_nil_block, comp.bool_to_lisp_obj); + comp.block = init_block; comp.func = comp.bool_to_lisp_obj; emit_cond_jump (gcc_jit_param_as_rvalue (param), ret_t_block, ret_nil_block); - block.gcc_bb = ret_t_block; - gcc_jit_block_end_with_return (ret_t_block, + + comp.block = ret_t_block; + gcc_jit_block_end_with_return (ret_t_block->gcc_bb, NULL, - emit_lisp_obj_from_ptr (&block, Qt)); - block.gcc_bb = ret_nil_block; - gcc_jit_block_end_with_return (ret_nil_block, + emit_lisp_obj_from_ptr (Qt)); + + comp.block = ret_nil_block; + gcc_jit_block_end_with_return (ret_nil_block->gcc_bb, NULL, - emit_lisp_obj_from_ptr (&block, Qnil)); + emit_lisp_obj_from_ptr (Qnil)); + + SAFE_FREE (); } static int @@ -1965,6 +1952,8 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, unsigned op; unsigned pushhandler_n = 0; + USE_SAFE_ALLOCA; + /* Meta-stack we use to flat the bytecode written for push and pop Emacs VM.*/ gcc_jit_lvalue **stack_base, **stack, **stack_over; @@ -2026,7 +2015,8 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, PUSH_PARAM (gcc_jit_function_get_param (comp.func, i)); gcc_jit_block_end_with_jump (prologue_bb, NULL, bb_map[0].gcc_bb); - gcc_jit_rvalue *nil = emit_lisp_obj_from_ptr (&bb_map[0], Qnil); + comp.block = &bb_map[0]; + gcc_jit_rvalue *nil = emit_lisp_obj_from_ptr (Qnil); comp.block = NULL; @@ -2093,7 +2083,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, op = FETCH; varref: { - args[0] = emit_lisp_obj_from_ptr (comp.block, vectorp[op]); + args[0] = emit_lisp_obj_from_ptr (vectorp[op]); res = emit_call ("Fsymbol_value", comp.lisp_obj_type, 1, args); PUSH_RVAL (res); break; @@ -2124,7 +2114,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, { POP1; args[1] = args[0]; - args[0] = emit_lisp_obj_from_ptr (comp.block, vectorp[op]); + args[0] = emit_lisp_obj_from_ptr (vectorp[op]); args[2] = nil; args[3] = gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.int_type, @@ -2157,7 +2147,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, op -= Bvarbind; varbind: { - args[0] = emit_lisp_obj_from_ptr (comp.block, vectorp[op]); + args[0] = emit_lisp_obj_from_ptr (vectorp[op]); pop (1, &stack, &args[1]); res = emit_call ("specbind", comp.lisp_obj_type, 2, args); PUSH_RVAL (res); @@ -2284,10 +2274,11 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, #else res = emit_call ("setjmp", comp.int_type, 1, args); #endif - gcc_jit_block *push_h_val_block = - gcc_jit_function_new_block (comp.func, - format_string ("push_h_val_%u", - pushhandler_n)); + basic_block_t *push_h_val_block; + SAFE_ALLOCA_BLOCK (push_h_val_block, + comp.func, + format_string ("push_h_val_%u", + pushhandler_n)); emit_cond_jump ( /* This negation is just to have a bool. */ gcc_jit_context_new_unary_op (comp.ctxt, @@ -2295,14 +2286,14 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, GCC_JIT_UNARY_OP_LOGICAL_NEGATE, comp.bool_type, res), - bb_map[pc].gcc_bb, + &bb_map[pc], push_h_val_block); gcc_jit_lvalue **stack_to_restore = stack; /* This emit the handler part. */ - basic_block_t bb_orig = *comp.block; - comp.block->gcc_bb = push_h_val_block; + basic_block_t *bb_orig = comp.block; + comp.block = push_h_val_block; /* current_thread->m_handlerlist = c->next; */ gcc_jit_lvalue *m_handlerlist = gcc_jit_rvalue_dereference_field (comp.current_thread, @@ -2322,9 +2313,9 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, NULL, comp.handler_val_field)); bb_map[handler_pc].top = stack; - *comp.block = bb_orig; + comp.block = bb_orig; - gcc_jit_block_end_with_jump (push_h_val_block, NULL, + gcc_jit_block_end_with_jump (push_h_val_block->gcc_bb, NULL, bb_map[handler_pc].gcc_bb); stack = stack_to_restore; @@ -2426,15 +2417,12 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, CASE (Bsub1); { - /* (FIXNUMP (TOP) && XFIXNUM (TOP) != MOST_NEGATIVE_FIXNUM ? make_fixnum (XFIXNUM (TOP) - 1) : Fsub1 (TOP)) */ - gcc_jit_block *sub1_inline_block = - gcc_jit_function_new_block (comp.func, "inline_sub1"); - gcc_jit_block *sub1_fcall_block = - gcc_jit_function_new_block (comp.func, "fcall_sub1"); + DECL_AND_SAFE_ALLOCA_BLOCK (sub1_inline_block, comp.func); + DECL_AND_SAFE_ALLOCA_BLOCK (sub1_fcall_block, comp.func); gcc_jit_rvalue *tos_as_num = emit_XFIXNUM (gcc_jit_lvalue_as_rvalue (TOS)); @@ -2463,38 +2451,38 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, tos_as_num, comp.one); - gcc_jit_block_add_assignment (sub1_inline_block, + basic_block_t *bb_orig = comp.block; + + comp.block = sub1_inline_block; + gcc_jit_block_add_assignment (sub1_inline_block->gcc_bb, NULL, TOS, - emit_make_fixnum (sub1_inline_block, - sub1_inline_res)); - basic_block_t bb_orig = *comp.block; + emit_make_fixnum (sub1_inline_res)); - comp.block->gcc_bb = sub1_fcall_block; + comp.block = sub1_fcall_block; POP1; res = emit_call ("Fsub1", comp.lisp_obj_type, 1, args); PUSH_RVAL (res); - *comp.block = bb_orig; - - gcc_jit_block_end_with_jump (sub1_inline_block, NULL, + gcc_jit_block_end_with_jump (sub1_inline_block->gcc_bb, + NULL, bb_map[pc].gcc_bb); - gcc_jit_block_end_with_jump (sub1_fcall_block, NULL, + gcc_jit_block_end_with_jump (sub1_fcall_block->gcc_bb, + NULL, bb_map[pc].gcc_bb); + comp.block = bb_orig; + SAFE_FREE (); } break; CASE (Badd1); { - /* (FIXNUMP (TOP) && XFIXNUM (TOP) != MOST_POSITIVE_FIXNUM ? make_fixnum (XFIXNUM (TOP) + 1) : Fadd (TOP)) */ - gcc_jit_block *add1_inline_block = - gcc_jit_function_new_block (comp.func, "inline_add1"); - gcc_jit_block *add1_fcall_block = - gcc_jit_function_new_block (comp.func, "fcall_add1"); + DECL_AND_SAFE_ALLOCA_BLOCK (add1_inline_block, comp.func); + DECL_AND_SAFE_ALLOCA_BLOCK (add1_fcall_block, comp.func); gcc_jit_rvalue *tos_as_num = emit_XFIXNUM (gcc_jit_lvalue_as_rvalue (TOS)); @@ -2523,24 +2511,27 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, tos_as_num, comp.one); - gcc_jit_block_add_assignment (add1_inline_block, + basic_block_t *bb_orig = comp.block; + comp.block = add1_inline_block; + + gcc_jit_block_add_assignment (add1_inline_block->gcc_bb + , NULL, TOS, - emit_make_fixnum (add1_inline_block, - add1_inline_res)); - basic_block_t bb_orig = *comp.block; - - comp.block->gcc_bb = add1_fcall_block; + emit_make_fixnum (add1_inline_res)); + comp.block = add1_fcall_block; POP1; res = emit_call ("Fadd1", comp.lisp_obj_type, 1, args); PUSH_RVAL (res); - *comp.block = bb_orig; - - gcc_jit_block_end_with_jump (add1_inline_block, NULL, + gcc_jit_block_end_with_jump (add1_inline_block->gcc_bb, + NULL, bb_map[pc].gcc_bb); - gcc_jit_block_end_with_jump (add1_fcall_block, NULL, + gcc_jit_block_end_with_jump (add1_fcall_block->gcc_bb, + NULL, bb_map[pc].gcc_bb); + comp.block = bb_orig; + SAFE_FREE (); } break; @@ -2570,15 +2561,12 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, CASE (Bnegate); { - /* (FIXNUMP (TOP) && XFIXNUM (TOP) != MOST_NEGATIVE_FIXNUM ? make_fixnum (- XFIXNUM (TOP)) : Fminus (1, &TOP)) */ - gcc_jit_block *negate_inline_block = - gcc_jit_function_new_block (comp.func, "inline_negate"); - gcc_jit_block *negate_fcall_block = - gcc_jit_function_new_block (comp.func, "fcall_negate"); + DECL_AND_SAFE_ALLOCA_BLOCK (negate_inline_block, comp.func); + DECL_AND_SAFE_ALLOCA_BLOCK (negate_fcall_block, comp.func); gcc_jit_rvalue *tos_as_num = emit_XFIXNUM (gcc_jit_lvalue_as_rvalue (TOS)); @@ -2606,21 +2594,25 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, comp.emacs_int_type, tos_as_num); - gcc_jit_block_add_assignment (negate_inline_block, + basic_block_t *bb_orig = comp.block; + + comp.block = negate_inline_block; + gcc_jit_block_add_assignment (negate_inline_block->gcc_bb, NULL, TOS, - emit_make_fixnum (negate_inline_block, - negate_inline_res)); - basic_block_t bb_orig = *comp.block; + emit_make_fixnum (negate_inline_res)); - comp.block->gcc_bb = negate_fcall_block; + comp.block = negate_fcall_block; EMIT_CALL_N_REF ("Fminus", 1); - *comp.block = bb_orig; - gcc_jit_block_end_with_jump (negate_inline_block, NULL, + gcc_jit_block_end_with_jump (negate_inline_block->gcc_bb, + NULL, bb_map[pc].gcc_bb); - gcc_jit_block_end_with_jump (negate_fcall_block, NULL, + gcc_jit_block_end_with_jump (negate_fcall_block->gcc_bb, + NULL, bb_map[pc].gcc_bb); + comp.block = bb_orig; + SAFE_FREE (); } break; CASE (Bplus); @@ -2710,8 +2702,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, break; CASE (Binteractive_p); /* Obsolete since 24.1. */ - PUSH_RVAL (emit_lisp_obj_from_ptr (comp.block, - intern ("interactive-p"))); + PUSH_RVAL (emit_lisp_obj_from_ptr (intern ("interactive-p"))); res = emit_call ("call0", comp.lisp_obj_type, 1, args); PUSH_RVAL (res); break; @@ -2745,7 +2736,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, op = FETCH2; POP1; emit_comparison_jump (GCC_JIT_COMPARISON_EQ, args[0], nil, - bb_map[op].gcc_bb, bb_map[pc].gcc_bb); + &bb_map[op], &bb_map[pc]); bb_map[op].top = stack; break; @@ -2753,7 +2744,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, op = FETCH2; POP1; emit_comparison_jump (GCC_JIT_COMPARISON_NE, args[0], nil, - bb_map[op].gcc_bb, bb_map[pc].gcc_bb); + &bb_map[op], &bb_map[pc]); bb_map[op].top = stack; break; @@ -2762,7 +2753,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, emit_comparison_jump (GCC_JIT_COMPARISON_EQ, gcc_jit_lvalue_as_rvalue (TOS), nil, - bb_map[op].gcc_bb, bb_map[pc].gcc_bb); + &bb_map[op], &bb_map[pc]); bb_map[op].top = stack; DISCARD (1); break; @@ -2772,7 +2763,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, emit_comparison_jump (GCC_JIT_COMPARISON_NE, gcc_jit_lvalue_as_rvalue (TOS), nil, - bb_map[op].gcc_bb, bb_map[pc].gcc_bb); + &bb_map[op], &bb_map[pc]); bb_map[op].top = stack; DISCARD (1); break; @@ -2803,8 +2794,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, break; CASE (Bsave_restriction); - args[0] = emit_lisp_obj_from_ptr (comp.block, - save_restriction_restore); + args[0] = emit_lisp_obj_from_ptr (save_restriction_restore); args[1] = emit_call ("save_restriction_save", comp.lisp_obj_type, 0, @@ -2815,7 +2805,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, CASE (Bcatch); /* Obsolete since 24.4. */ POP2; args[2] = args[1]; - args[1] = emit_lisp_obj_from_ptr (comp.block, eval_sub); + args[1] = emit_lisp_obj_from_ptr (eval_sub); emit_call ("internal_catch", comp.void_ptr_type, 3, args); break; @@ -2932,7 +2922,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, op += pc; POP1; emit_comparison_jump (GCC_JIT_COMPARISON_EQ, args[0], nil, - bb_map[op].gcc_bb, bb_map[pc].gcc_bb); + &bb_map[op], &bb_map[pc]); bb_map[op].top = stack; break; @@ -2941,7 +2931,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, op += pc; POP1; emit_comparison_jump (GCC_JIT_COMPARISON_NE, args[0], nil, - bb_map[op].gcc_bb, bb_map[pc].gcc_bb); + &bb_map[op], &bb_map[pc]); bb_map[op].top = stack; break; @@ -2951,7 +2941,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, emit_comparison_jump (GCC_JIT_COMPARISON_EQ, gcc_jit_lvalue_as_rvalue (TOS), nil, - bb_map[op].gcc_bb, bb_map[pc].gcc_bb); + &bb_map[op], &bb_map[pc]); bb_map[op].top = stack; DISCARD (1); break; @@ -2962,7 +2952,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, emit_comparison_jump (GCC_JIT_COMPARISON_NE, gcc_jit_lvalue_as_rvalue (TOS), nil, - bb_map[op].gcc_bb, bb_map[pc].gcc_bb); + &bb_map[op], &bb_map[pc]); bb_map[op].top = stack; DISCARD (1); break; @@ -3029,7 +3019,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, if (pc >= bytestr_length || bytestr_data[pc] != Bswitch) { gcc_jit_rvalue *c = - emit_lisp_obj_from_ptr (comp.block, vectorp[op]); + emit_lisp_obj_from_ptr (vectorp[op]); PUSH_RVAL (c); break; } @@ -3051,6 +3041,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, exit: xfree (stack_base); xfree (bb_map); + SAFE_FREE (); return comp_res; } commit ecf40f95a65d3232a1295be2361f07abede48b23 Author: Andrea Corallo Date: Sat Jun 29 15:42:27 2019 +0200 emit comments for inlined functions diff --git a/src/comp.c b/src/comp.c index 87303ab3ef..5be5fa51d3 100644 --- a/src/comp.c +++ b/src/comp.c @@ -123,10 +123,7 @@ along with GNU Emacs. If not, see . */ #define CASE(op) \ case op : \ - if (COMP_DEBUG) \ - gcc_jit_block_add_comment (comp.block->gcc_bb, \ - NULL, \ - "Opcode " STR(op)); + emit_comment (STR(op)) /* Pop from the meta-stack, emit the call and push the result */ @@ -140,7 +137,7 @@ along with GNU Emacs. If not, see . */ /* Generate appropriate case and emit call to function. */ #define CASE_CALL_N(name, nargs) \ - CASE (B##name) \ + CASE (B##name); \ EMIT_CALL_N (STR(F##name), nargs); \ break @@ -334,6 +331,15 @@ type_to_cast_field (gcc_jit_type *type) return field; } +INLINE static void +emit_comment (const char *str) +{ + if (COMP_DEBUG) + gcc_jit_block_add_comment (comp.block->gcc_bb, + NULL, + str); +} + static gcc_jit_function * emit_func_declare (const char *f_name, gcc_jit_type *ret_type, unsigned nargs, gcc_jit_rvalue **args, @@ -500,6 +506,8 @@ emit_cast (gcc_jit_type *new_type, gcc_jit_rvalue *obj) INLINE static gcc_jit_rvalue * emit_XLI (gcc_jit_rvalue *obj) { + emit_comment ("XLI"); + return gcc_jit_rvalue_access_field (obj, NULL, comp.lisp_obj_as_num); @@ -508,6 +516,8 @@ emit_XLI (gcc_jit_rvalue *obj) INLINE static gcc_jit_lvalue * emit_lval_XLI (gcc_jit_lvalue *obj) { + emit_comment ("lval_XLI"); + return gcc_jit_lvalue_access_field (obj, NULL, comp.lisp_obj_as_num); @@ -516,6 +526,8 @@ emit_lval_XLI (gcc_jit_lvalue *obj) INLINE static gcc_jit_rvalue * emit_XLP (gcc_jit_rvalue *obj) { + emit_comment ("XLP"); + return gcc_jit_rvalue_access_field (obj, NULL, comp.lisp_obj_as_ptr); @@ -524,6 +536,8 @@ emit_XLP (gcc_jit_rvalue *obj) INLINE static gcc_jit_lvalue * emit_lval_XLP (gcc_jit_lvalue *obj) { + emit_comment ("lval_XLP"); + return gcc_jit_lvalue_access_field (obj, NULL, comp.lisp_obj_as_ptr); @@ -534,6 +548,7 @@ emit_XUNTAG (gcc_jit_rvalue *a, gcc_jit_type *type, unsigned lisp_word_tag) { /* #define XUNTAG(a, type, ctype) ((ctype *) ((char *) XLP (a) - LISP_WORD_TAG (type))) */ + emit_comment ("XUNTAG"); return emit_cast (gcc_jit_type_get_pointer (type), gcc_jit_context_new_binary_op ( @@ -550,6 +565,8 @@ emit_XUNTAG (gcc_jit_rvalue *a, gcc_jit_type *type, unsigned lisp_word_tag) static gcc_jit_rvalue * emit_XCONS (gcc_jit_rvalue *a) { + emit_comment ("XCONS"); + return emit_XUNTAG (a, gcc_jit_struct_as_type (comp.lisp_cons_s), LISP_WORD_TAG (Lisp_Cons)); @@ -558,6 +575,8 @@ emit_XCONS (gcc_jit_rvalue *a) static gcc_jit_rvalue * emit_EQ (gcc_jit_rvalue *x, gcc_jit_rvalue *y) { + emit_comment ("EQ"); + return gcc_jit_context_new_comparison ( comp.ctxt, NULL, @@ -572,6 +591,7 @@ emit_TAGGEDP (gcc_jit_rvalue *obj, unsigned tag) /* (! (((unsigned) (XLI (a) >> (USE_LSB_TAG ? 0 : VALBITS)) \ - (unsigned) (tag)) \ & ((1 << GCTYPEBITS) - 1))) */ + emit_comment ("TAGGEDP"); gcc_jit_rvalue *sh_res = gcc_jit_context_new_binary_op ( @@ -617,18 +637,24 @@ emit_TAGGEDP (gcc_jit_rvalue *obj, unsigned tag) static gcc_jit_rvalue * emit_VECTORLIKEP (gcc_jit_rvalue *obj) { + emit_comment ("VECTORLIKEP"); + return emit_TAGGEDP (obj, Lisp_Vectorlike); } static gcc_jit_rvalue * emit_CONSP (gcc_jit_rvalue *obj) { + emit_comment ("CONSP"); + return emit_TAGGEDP (obj, Lisp_Cons); } static gcc_jit_rvalue * emit_FLOATP (gcc_jit_rvalue *obj) { + emit_comment ("FLOATP"); + return emit_TAGGEDP (obj, Lisp_Float); } @@ -636,6 +662,8 @@ static gcc_jit_rvalue * emit_BIGNUMP (gcc_jit_rvalue *obj) { /* PSEUDOVECTORP (x, PVEC_BIGNUM); */ + emit_comment ("BIGNUMP"); + gcc_jit_rvalue *args[2] = { obj, gcc_jit_context_new_rvalue_from_int (comp.ctxt, @@ -655,6 +683,7 @@ emit_FIXNUMP (gcc_jit_rvalue *obj) /* (! (((unsigned) (XLI (x) >> (USE_LSB_TAG ? 0 : FIXNUM_BITS)) - (unsigned) (Lisp_Int0 >> !USE_LSB_TAG)) & ((1 << INTTYPEBITS) - 1))) */ + emit_comment ("FIXNUMP"); gcc_jit_rvalue *sh_res = gcc_jit_context_new_binary_op ( @@ -700,6 +729,8 @@ emit_FIXNUMP (gcc_jit_rvalue *obj) static gcc_jit_rvalue * emit_XFIXNUM (gcc_jit_rvalue *obj) { + emit_comment ("XFIXNUM"); + return gcc_jit_context_new_binary_op (comp.ctxt, NULL, GCC_JIT_BINARY_OP_RSHIFT, @@ -711,6 +742,8 @@ emit_XFIXNUM (gcc_jit_rvalue *obj) static gcc_jit_rvalue * emit_INTEGERP (gcc_jit_rvalue *obj) { + emit_comment ("INTEGERP"); + return gcc_jit_context_new_binary_op (comp.ctxt, NULL, GCC_JIT_BINARY_OP_LOGICAL_OR, @@ -723,6 +756,8 @@ emit_INTEGERP (gcc_jit_rvalue *obj) static gcc_jit_rvalue * emit_NUMBERP (gcc_jit_rvalue *obj) { + emit_comment ("NUMBERP"); + return gcc_jit_context_new_binary_op (comp.ctxt, NULL, GCC_JIT_BINARY_OP_LOGICAL_OR, @@ -735,6 +770,8 @@ emit_NUMBERP (gcc_jit_rvalue *obj) static gcc_jit_rvalue * emit_make_fixnum (gcc_jit_block *block, gcc_jit_rvalue *obj) { + emit_comment ("make_fixnum"); + gcc_jit_rvalue *tmp = gcc_jit_context_new_binary_op (comp.ctxt, NULL, @@ -764,12 +801,15 @@ emit_make_fixnum (gcc_jit_block *block, gcc_jit_rvalue *obj) } /* Construct fill and return a lisp object form a raw pointer. */ -/* TODO should we pass the bb? */ +/* FIXME do not pass bb */ static gcc_jit_rvalue * emit_lisp_obj_from_ptr (basic_block_t *block, void *p) { static unsigned i; + comp.block = block; + emit_comment ("lisp_obj_from_ptr"); + gcc_jit_lvalue *lisp_obj = gcc_jit_function_new_local (comp.func, NULL, @@ -781,9 +821,7 @@ emit_lisp_obj_from_ptr (basic_block_t *block, void *p) p); if (SYMBOLP (p)) - gcc_jit_block_add_comment ( - block->gcc_bb, - NULL, + emit_comment ( format_string ("Symbol %s", (char *) SDATA (SYMBOL_NAME (p)))); @@ -797,12 +835,16 @@ emit_lisp_obj_from_ptr (basic_block_t *block, void *p) static gcc_jit_rvalue * emit_NILP (gcc_jit_rvalue *x) { + emit_comment ("NILP"); + return emit_EQ (x, emit_lisp_obj_from_ptr (comp.block, Qnil)); } static gcc_jit_rvalue * emit_XCAR (gcc_jit_rvalue *c) { + emit_comment ("XCAR"); + /* XCONS (c)->u.s.car */ return gcc_jit_rvalue_access_field ( @@ -823,6 +865,8 @@ emit_XCAR (gcc_jit_rvalue *c) static gcc_jit_lvalue * emit_lval_XCAR (gcc_jit_rvalue *c) { + emit_comment ("lval_XCAR"); + /* XCONS (c)->u.s.car */ return gcc_jit_lvalue_access_field ( @@ -842,6 +886,7 @@ emit_lval_XCAR (gcc_jit_rvalue *c) static gcc_jit_rvalue * emit_XCDR (gcc_jit_rvalue *c) { + emit_comment ("XCDR"); /* XCONS (c)->u.s.u.cdr */ return gcc_jit_rvalue_access_field ( @@ -866,6 +911,8 @@ emit_XCDR (gcc_jit_rvalue *c) static void emit_CHECK_CONS (gcc_jit_rvalue *x) { + emit_comment ("CHECK_CONS"); + gcc_jit_rvalue *args[] = { emit_CONSP (x), emit_lisp_obj_from_ptr (comp.block, Qconsp), @@ -882,12 +929,16 @@ emit_CHECK_CONS (gcc_jit_rvalue *x) static gcc_jit_rvalue * emit_car_addr (gcc_jit_rvalue *c) { + emit_comment ("car_addr"); + return gcc_jit_lvalue_get_address (emit_lval_XCAR (c), NULL); } static void emit_XSETCAR (gcc_jit_rvalue *c, gcc_jit_rvalue *n) { + emit_comment ("XSETCAR"); + gcc_jit_block_add_assignment( comp.block->gcc_bb, NULL, @@ -900,6 +951,9 @@ emit_XSETCAR (gcc_jit_rvalue *c, gcc_jit_rvalue *n) static gcc_jit_rvalue * emit_PURE_P (gcc_jit_rvalue *ptr) { + + emit_comment ("PURE_P"); + return gcc_jit_context_new_comparison ( comp.ctxt, @@ -1995,47 +2049,47 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, switch (op) { - CASE (Bstack_ref1) + CASE (Bstack_ref1); goto stack_ref; - CASE (Bstack_ref2) + CASE (Bstack_ref2); goto stack_ref; - CASE (Bstack_ref3) + CASE (Bstack_ref3); goto stack_ref; - CASE (Bstack_ref4) + CASE (Bstack_ref4); goto stack_ref; - CASE (Bstack_ref5) + CASE (Bstack_ref5); stack_ref: PUSH_LVAL (stack_base[(stack - stack_base) - (op - Bstack_ref) - 1]); break; - CASE (Bstack_ref6) + CASE (Bstack_ref6); PUSH_LVAL (stack_base[(stack - stack_base) - FETCH - 1]); break; - CASE (Bstack_ref7) + CASE (Bstack_ref7); PUSH_LVAL (stack_base[(stack - stack_base) - FETCH2 - 1]); break; - CASE (Bvarref7) + CASE (Bvarref7); op = FETCH2; goto varref; - CASE (Bvarref) + CASE (Bvarref); goto varref_count; - CASE (Bvarref1) + CASE (Bvarref1); goto varref_count; - CASE (Bvarref2) + CASE (Bvarref2); goto varref_count; - CASE (Bvarref3) + CASE (Bvarref3); goto varref_count; - CASE (Bvarref4) + CASE (Bvarref4); goto varref_count; - CASE (Bvarref5) + CASE (Bvarref5); varref_count: op -= Bvarref; goto varref; - CASE (Bvarref6) + CASE (Bvarref6); op = FETCH; varref: { @@ -2045,26 +2099,26 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, break; } - CASE (Bvarset) + CASE (Bvarset); goto varset_count; - CASE (Bvarset1) + CASE (Bvarset1); goto varset_count; - CASE (Bvarset2) + CASE (Bvarset2); goto varset_count; - CASE (Bvarset3) + CASE (Bvarset3); goto varset_count; - CASE (Bvarset4) + CASE (Bvarset4); goto varset_count; - CASE (Bvarset5) + CASE (Bvarset5); varset_count: op -= Bvarset; goto varset; - CASE (Bvarset7) + CASE (Bvarset7); op = FETCH2; goto varset; - CASE (Bvarset6) + CASE (Bvarset6); op = FETCH; varset: { @@ -2080,25 +2134,25 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, } break; - CASE (Bvarbind6) + CASE (Bvarbind6); op = FETCH; goto varbind; - CASE (Bvarbind7) + CASE (Bvarbind7); op = FETCH2; goto varbind; - CASE (Bvarbind) + CASE (Bvarbind); goto varbind_count; - CASE (Bvarbind1) + CASE (Bvarbind1); goto varbind_count; - CASE (Bvarbind2) + CASE (Bvarbind2); goto varbind_count; - CASE (Bvarbind3) + CASE (Bvarbind3); goto varbind_count; - CASE (Bvarbind4) + CASE (Bvarbind4); goto varbind_count; - CASE (Bvarbind5) + CASE (Bvarbind5); varbind_count: op -= Bvarbind; varbind: @@ -2110,25 +2164,25 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, break; } - CASE (Bcall6) + CASE (Bcall6); op = FETCH; goto docall; - CASE (Bcall7) + CASE (Bcall7); op = FETCH2; goto docall; - CASE (Bcall) + CASE (Bcall); goto docall_count; - CASE (Bcall1) + CASE (Bcall1); goto docall_count; - CASE (Bcall2) + CASE (Bcall2); goto docall_count; - CASE (Bcall3) + CASE (Bcall3); goto docall_count; - CASE (Bcall4) + CASE (Bcall4); goto docall_count; - CASE (Bcall5) + CASE (Bcall5); docall_count: op -= Bcall; docall: @@ -2140,25 +2194,25 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, break; } - CASE (Bunbind6) + CASE (Bunbind6); op = FETCH; goto dounbind; - CASE (Bunbind7) + CASE (Bunbind7); op = FETCH2; goto dounbind; - CASE (Bunbind) + CASE (Bunbind); goto dounbind_count; - CASE (Bunbind1) + CASE (Bunbind1); goto dounbind_count; - CASE (Bunbind2) + CASE (Bunbind2); goto dounbind_count; - CASE (Bunbind3) + CASE (Bunbind3); goto dounbind_count; - CASE (Bunbind4) + CASE (Bunbind4); goto dounbind_count; - CASE (Bunbind5) + CASE (Bunbind5); dounbind_count: op -= Bunbind; dounbind: @@ -2171,7 +2225,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, } break; - CASE (Bpophandler) + CASE (Bpophandler); { /* current_thread->m_handlerlist = current_thread->m_handlerlist->next; */ @@ -2192,11 +2246,11 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, break; } - CASE (Bpushconditioncase) /* New in 24.4. */ + CASE (Bpushconditioncase); /* New in 24.4. */ type = CONDITION_CASE; goto pushhandler; - CASE (Bpushcatch) /* New in 24.4. */ + CASE (Bpushcatch); /* New in 24.4. */ type = CATCHER; pushhandler: { @@ -2281,7 +2335,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, CASE_CALL_N (nth, 2); CASE_CALL_N (symbolp, 1); - CASE (Bconsp) + CASE (Bconsp); POP1; res = emit_cast (comp.bool_type, emit_CONSP (args[0])); @@ -2318,17 +2372,17 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, CASE_CALL_N (cons, 2); - CASE (BlistN) + CASE (BlistN); op = FETCH; goto make_list; - CASE (Blist1) + CASE (Blist1); goto make_list_count; - CASE (Blist2) + CASE (Blist2); goto make_list_count; - CASE (Blist3) + CASE (Blist3); goto make_list_count; - CASE (Blist4) + CASE (Blist4); make_list_count: op = op - Blist1; make_list: @@ -2356,21 +2410,21 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, CASE_CALL_N (get, 2); CASE_CALL_N (substring, 3); - CASE (Bconcat2) + CASE (Bconcat2); EMIT_CALL_N_REF ("Fconcat", 2); break; - CASE (Bconcat3) + CASE (Bconcat3); EMIT_CALL_N_REF ("Fconcat", 3); break; - CASE (Bconcat4) + CASE (Bconcat4); EMIT_CALL_N_REF ("Fconcat", 4); break; - CASE (BconcatN) + CASE (BconcatN); op = FETCH; EMIT_CALL_N_REF ("Fconcat", op); break; - CASE (Bsub1) + CASE (Bsub1); { /* (FIXNUMP (TOP) && XFIXNUM (TOP) != MOST_NEGATIVE_FIXNUM @@ -2430,7 +2484,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, } break; - CASE (Badd1) + CASE (Badd1); { /* (FIXNUMP (TOP) && XFIXNUM (TOP) != MOST_POSITIVE_FIXNUM @@ -2490,31 +2544,31 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, } break; - CASE (Beqlsign) + CASE (Beqlsign); EMIT_ARITHCOMPARE (ARITH_EQUAL); break; - CASE (Bgtr) + CASE (Bgtr); EMIT_ARITHCOMPARE (ARITH_GRTR); break; - CASE (Blss) + CASE (Blss); EMIT_ARITHCOMPARE (ARITH_LESS); break; - CASE (Bleq) + CASE (Bleq); EMIT_ARITHCOMPARE (ARITH_LESS_OR_EQUAL); break; - CASE (Bgeq) + CASE (Bgeq); EMIT_ARITHCOMPARE (ARITH_GRTR_OR_EQUAL); break; - CASE (Bdiff) + CASE (Bdiff); EMIT_CALL_N_REF ("Fminus", 2); break; - CASE (Bnegate) + CASE (Bnegate); { /* (FIXNUMP (TOP) && XFIXNUM (TOP) != MOST_NEGATIVE_FIXNUM @@ -2569,19 +2623,19 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, bb_map[pc].gcc_bb); } break; - CASE (Bplus) + CASE (Bplus); EMIT_CALL_N_REF ("Fplus", 2); break; - CASE (Bmax) + CASE (Bmax); EMIT_CALL_N_REF ("Fmax", 2); break; - CASE (Bmin) + CASE (Bmin); EMIT_CALL_N_REF ("Fmin", 2); break; - CASE (Bmult) + CASE (Bmult); EMIT_CALL_N_REF ("Ftimes", 2); break; - CASE (Bpoint) + CASE (Bpoint); args[0] = gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.ptrdiff_type, @@ -2595,11 +2649,11 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, CASE_CALL_N (goto_char, 1); - CASE (Binsert) + CASE (Binsert); EMIT_CALL_N_REF ("Finsert", 1); break; - CASE (Bpoint_max) + CASE (Bpoint_max); args[0] = gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.ptrdiff_type, @@ -2611,7 +2665,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, PUSH_RVAL (res); break; - CASE (Bpoint_min) + CASE (Bpoint_min); args[0] = gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.ptrdiff_type, @@ -2626,14 +2680,14 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, CASE_CALL_N (char_after, 1); CASE_CALL_N (following_char, 0); - CASE (Bpreceding_char) + CASE (Bpreceding_char); res = emit_call ("Fprevious_char", comp.lisp_obj_type, 0, args); PUSH_RVAL (res); break; CASE_CALL_N (current_column, 0); - CASE (Bindent_to) + CASE (Bindent_to); POP1; args[1] = nil; res = emit_call ("Findent_to", comp.lisp_obj_type, 2, args); @@ -2647,15 +2701,15 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, CASE_CALL_N (current_buffer, 0); CASE_CALL_N (set_buffer, 1); - CASE (Bsave_current_buffer) /* Obsolete since ??. */ + CASE (Bsave_current_buffer); /* Obsolete since ??. */ goto save_current; - CASE (Bsave_current_buffer_1) + CASE (Bsave_current_buffer_1); save_current: emit_call ("record_unwind_current_buffer", comp.void_type, 0, NULL); break; - CASE (Binteractive_p) /* Obsolete since 24.1. */ + CASE (Binteractive_p); /* Obsolete since 24.1. */ PUSH_RVAL (emit_lisp_obj_from_ptr (comp.block, intern ("interactive-p"))); res = emit_call ("call0", comp.lisp_obj_type, 1, args); @@ -2674,11 +2728,11 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, CASE_CALL_N (widen, 0); CASE_CALL_N (end_of_line, 1); - CASE (Bconstant2) + CASE (Bconstant2); goto do_constant; break; - CASE (Bgoto) + CASE (Bgoto); op = FETCH2; gcc_jit_block_end_with_jump (comp.block->gcc_bb, NULL, @@ -2687,7 +2741,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, bb_map[op].top = stack; break; - CASE (Bgotoifnil) + CASE (Bgotoifnil); op = FETCH2; POP1; emit_comparison_jump (GCC_JIT_COMPARISON_EQ, args[0], nil, @@ -2695,7 +2749,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, bb_map[op].top = stack; break; - CASE (Bgotoifnonnil) + CASE (Bgotoifnonnil); op = FETCH2; POP1; emit_comparison_jump (GCC_JIT_COMPARISON_NE, args[0], nil, @@ -2703,7 +2757,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, bb_map[op].top = stack; break; - CASE (Bgotoifnilelsepop) + CASE (Bgotoifnilelsepop); op = FETCH2; emit_comparison_jump (GCC_JIT_COMPARISON_EQ, gcc_jit_lvalue_as_rvalue (TOS), @@ -2713,7 +2767,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, DISCARD (1); break; - CASE (Bgotoifnonnilelsepop) + CASE (Bgotoifnonnilelsepop); op = FETCH2; emit_comparison_jump (GCC_JIT_COMPARISON_NE, gcc_jit_lvalue_as_rvalue (TOS), @@ -2723,7 +2777,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, DISCARD (1); break; - CASE (Breturn) + CASE (Breturn); POP1; gcc_jit_block_end_with_return(comp.block->gcc_bb, NULL, @@ -2731,24 +2785,24 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, comp.block->terminated = true; break; - CASE (Bdiscard) + CASE (Bdiscard); DISCARD (1); break; - CASE (Bdup) + CASE (Bdup); PUSH_LVAL (TOS); break; - CASE (Bsave_excursion) + CASE (Bsave_excursion); res = emit_call ("record_unwind_protect_excursion", comp.void_type, 0, args); break; - CASE (Bsave_window_excursion) /* Obsolete since 24.1. */ + CASE (Bsave_window_excursion); /* Obsolete since 24.1. */ EMIT_CALL_N ("helper_save_window_excursion", 1); break; - CASE (Bsave_restriction) + CASE (Bsave_restriction); args[0] = emit_lisp_obj_from_ptr (comp.block, save_restriction_restore); args[1] = emit_call ("save_restriction_save", @@ -2758,29 +2812,29 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, emit_call ("record_unwind_protect", comp.void_ptr_type, 2, args); break; - CASE (Bcatch) /* Obsolete since 24.4. */ + CASE (Bcatch); /* Obsolete since 24.4. */ POP2; args[2] = args[1]; args[1] = emit_lisp_obj_from_ptr (comp.block, eval_sub); emit_call ("internal_catch", comp.void_ptr_type, 3, args); break; - CASE (Bunwind_protect) /* FIXME: avoid closure for lexbind. */ + CASE (Bunwind_protect); /* FIXME: avoid closure for lexbind. */ POP1; emit_call ("helper_unwind_protect", comp.void_type, 1, args); break; - CASE (Bcondition_case) /* Obsolete since 24.4. */ + CASE (Bcondition_case); /* Obsolete since 24.4. */ POP3; emit_call ("internal_lisp_condition_case", comp.lisp_obj_type, 3, args); break; - CASE (Btemp_output_buffer_setup) /* Obsolete since 24.1. */ + CASE (Btemp_output_buffer_setup); /* Obsolete since 24.1. */ EMIT_CALL_N ("helper_temp_output_buffer_setup", 1); break; - CASE (Btemp_output_buffer_show) /* Obsolete since 24.1. */ + CASE (Btemp_output_buffer_show); /* Obsolete since 24.1. */ POP2; emit_call ("temp_output_buffer_show", comp.void_type, 1, &args[1]); @@ -2788,7 +2842,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, emit_call ("helper_unbind_n", comp.lisp_obj_type, 1, args); break; - CASE (Bunbind_all) /* Obsolete. Never used. */ + CASE (Bunbind_all); /* Obsolete. Never used. */ /* To unbind back to the beginning of this frame. Not used yet, but will be needed for tail-recursion elimination. */ error ("Bunbind_all not supported"); @@ -2800,11 +2854,11 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, CASE_CALL_N (upcase, 1); CASE_CALL_N (downcase, 1); - CASE (Bstringeqlsign) + CASE (Bstringeqlsign); EMIT_CALL_N ("Fstring_equal", 2); break; - CASE (Bstringlss) + CASE (Bstringlss); EMIT_CALL_N ("Fstring_lessp", 2); break; @@ -2825,25 +2879,25 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, CASE_CALL_N (setcdr, 2); - CASE (Bcar_safe) + CASE (Bcar_safe); EMIT_CALL_N ("CAR_SAFE", 1); break; - CASE (Bcdr_safe) + CASE (Bcdr_safe); EMIT_CALL_N ("CDR_SAFE", 1); break; - CASE (Bnconc) + CASE (Bnconc); EMIT_CALL_N_REF ("Fnconc", 2); break; - CASE (Bquo) + CASE (Bquo); EMIT_CALL_N_REF ("Fquo", 2); break; CASE_CALL_N (rem, 2); - CASE (Bnumberp) + CASE (Bnumberp); POP1; res = emit_NUMBERP (args[0]); res = gcc_jit_context_new_call (comp.ctxt, @@ -2853,7 +2907,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, PUSH_RVAL (res); break; - CASE (Bintegerp) + CASE (Bintegerp); POP1; res = emit_INTEGERP(args[0]); res = gcc_jit_context_new_call (comp.ctxt, @@ -2863,7 +2917,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, PUSH_RVAL (res); break; - CASE (BRgoto) + CASE (BRgoto); op = FETCH - 128; op += pc; gcc_jit_block_end_with_jump (comp.block->gcc_bb, @@ -2873,7 +2927,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, bb_map[op].top = stack; break; - CASE (BRgotoifnil) + CASE (BRgotoifnil); op = FETCH - 128; op += pc; POP1; @@ -2882,7 +2936,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, bb_map[op].top = stack; break; - CASE (BRgotoifnonnil) + CASE (BRgotoifnonnil); op = FETCH - 128; op += pc; POP1; @@ -2891,7 +2945,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, bb_map[op].top = stack; break; - CASE (BRgotoifnilelsepop) + CASE (BRgotoifnilelsepop); op = FETCH - 128; op += pc; emit_comparison_jump (GCC_JIT_COMPARISON_EQ, @@ -2902,7 +2956,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, DISCARD (1); break; - CASE (BRgotoifnonnilelsepop) + CASE (BRgotoifnonnilelsepop); op = FETCH - 128; op += pc; emit_comparison_jump (GCC_JIT_COMPARISON_NE, @@ -2913,12 +2967,12 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, DISCARD (1); break; - CASE (BinsertN) + CASE (BinsertN); op = FETCH; EMIT_CALL_N_REF ("Finsert", op); break; - CASE (Bstack_set) + CASE (Bstack_set); /* stack-set-0 = discard; stack-set-1 = discard-1-preserve-tos. */ op = FETCH; POP1; @@ -2929,7 +2983,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, args[0]); break; - CASE (Bstack_set2) + CASE (Bstack_set2); op = FETCH2; POP1; gcc_jit_block_add_assignment (comp.block->gcc_bb, @@ -2938,7 +2992,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, args[0]); break; - CASE (BdiscardN) + CASE (BdiscardN); op = FETCH; if (op & 0x80) { @@ -2952,7 +3006,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, DISCARD (op); break; - CASE (Bswitch) + CASE (Bswitch); error ("Bswitch not supported"); /* The cases of Bswitch that we handle (which in theory is all of them) are done in Bconstant, below. This is done @@ -2963,7 +3017,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, break; default: - CASE (Bconstant) + CASE (Bconstant); { if (op < Bconstant || op > Bconstant + vector_size) goto fail; commit 5202f742b0f5f0a5c317d66a8ce6a8e84e86dffc Author: Andrea Corallo Date: Sat Jun 29 12:08:24 2019 +0200 add setcar diff --git a/src/comp.c b/src/comp.c index e5c98a84c3..87303ab3ef 100644 --- a/src/comp.c +++ b/src/comp.c @@ -243,6 +243,7 @@ typedef struct { gcc_jit_function *bool_to_lisp_obj; gcc_jit_function *car; gcc_jit_function *cdr; + gcc_jit_function *setcar; gcc_jit_function *check_type; gcc_jit_function *check_impure; basic_block_t *block; /* Current basic block */ @@ -819,6 +820,25 @@ emit_XCAR (gcc_jit_rvalue *c) comp.lisp_cons_u_s_car); } +static gcc_jit_lvalue * +emit_lval_XCAR (gcc_jit_rvalue *c) +{ + /* XCONS (c)->u.s.car */ + return + gcc_jit_lvalue_access_field ( + /* XCONS (c)->u.s */ + gcc_jit_lvalue_access_field ( + /* XCONS (c)->u */ + gcc_jit_rvalue_dereference_field ( + emit_XCONS (c), + NULL, + comp.lisp_cons_u), + NULL, + comp.lisp_cons_u_s), + NULL, + comp.lisp_cons_u_s_car); +} + static gcc_jit_rvalue * emit_XCDR (gcc_jit_rvalue *c) { @@ -859,6 +879,24 @@ emit_CHECK_CONS (gcc_jit_rvalue *x) args); } +static gcc_jit_rvalue * +emit_car_addr (gcc_jit_rvalue *c) +{ + return gcc_jit_lvalue_get_address (emit_lval_XCAR (c), NULL); +} + +static void +emit_XSETCAR (gcc_jit_rvalue *c, gcc_jit_rvalue *n) +{ + gcc_jit_block_add_assignment( + comp.block->gcc_bb, + NULL, + gcc_jit_rvalue_dereference ( + emit_car_addr (c), + NULL), + n); +} + static gcc_jit_rvalue * emit_PURE_P (gcc_jit_rvalue *ptr) { @@ -1376,12 +1414,54 @@ define_CAR_CDR (void) } } +static void +define_setcar (void) +{ + + gcc_jit_param *cell = + gcc_jit_context_new_param (comp.ctxt, + NULL, + comp.lisp_obj_type, + "cell"); + gcc_jit_param *new_car = + gcc_jit_context_new_param (comp.ctxt, + NULL, + comp.lisp_obj_type, + "new_car"); + + gcc_jit_param *param[] = { cell, new_car }; + comp.setcar = + gcc_jit_context_new_function (comp.ctxt, NULL, + GCC_JIT_FUNCTION_ALWAYS_INLINE, + comp.lisp_obj_type, + "setcar", + 2, + param, + 0); + gcc_jit_block *initial_block = + gcc_jit_function_new_block (comp.setcar, "initial_block"); + /* Set current context as needed */ + basic_block_t block = { .gcc_bb = initial_block, + .terminated = false }; + comp.block = █ + comp.func = comp.setcar; + + emit_CHECK_CONS (gcc_jit_param_as_rvalue (cell)); + + emit_XSETCAR (gcc_jit_param_as_rvalue (cell), + gcc_jit_param_as_rvalue (new_car)); + + gcc_jit_block_end_with_return (initial_block, + NULL, + gcc_jit_param_as_rvalue (new_car)); + +} /* Declare a substitute for PSEUDOVECTORP as always inlined function. */ static void define_PSEUDOVECTORP (void) { - gcc_jit_param *param[2] = + gcc_jit_param *param[] = { gcc_jit_context_new_param (comp.ctxt, NULL, comp.lisp_obj_type, @@ -1803,6 +1883,7 @@ init_comp (int opt_level) define_CHECK_TYPE (); define_CHECK_IMPURE (); define_bool_to_lisp_obj (); + define_setcar(); } static void @@ -2732,7 +2813,16 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, CASE_CALL_N (elt, 2); CASE_CALL_N (member, 2); CASE_CALL_N (assq, 2); - CASE_CALL_N (setcar, 2); + + case Bsetcar: + POP2; + res = gcc_jit_context_new_call (comp.ctxt, + NULL, + comp.setcar, + 2, args); + PUSH_RVAL (res); + break; + CASE_CALL_N (setcdr, 2); CASE (Bcar_safe) diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 31b2f0f001..8fd3ca2e19 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -313,12 +313,20 @@ (defun comp-tests-consp-f (x) ;; Bconsp (consp x)) + (defun comp-tests-car-f (x) + ;; Bsetcar + (setcar x 3)) (byte-compile #'comp-tests-consp-f) (native-compile #'comp-tests-consp-f) + (byte-compile #'comp-tests-car-f) + (native-compile #'comp-tests-car-f) (should (eq (comp-tests-consp-f '(1)) t)) - (should (eq (comp-tests-consp-f 1) nil))) + (should (eq (comp-tests-consp-f 1) nil)) + (let ((x (cons 1 2))) + (should (= (comp-tests-car-f x) 3)) + (should (equal x '(3 . 2))))) (ert-deftest comp-tests-num-inline () "Test some inlined number functions." commit 34b3dac89ed681aa09b4d6b0e381504aa3adeb58 Author: Andrea Corallo Date: Sat Jun 29 11:17:36 2019 +0200 homogeneous emit names diff --git a/src/comp.c b/src/comp.c index 07b6984acf..e5c98a84c3 100644 --- a/src/comp.c +++ b/src/comp.c @@ -497,7 +497,7 @@ emit_cast (gcc_jit_type *new_type, gcc_jit_rvalue *obj) } INLINE static gcc_jit_rvalue * -emit_rval_XLI (gcc_jit_rvalue *obj) +emit_XLI (gcc_jit_rvalue *obj) { return gcc_jit_rvalue_access_field (obj, NULL, @@ -513,7 +513,7 @@ emit_lval_XLI (gcc_jit_lvalue *obj) } INLINE static gcc_jit_rvalue * -emit_rval_XLP (gcc_jit_rvalue *obj) +emit_XLP (gcc_jit_rvalue *obj) { return gcc_jit_rvalue_access_field (obj, NULL, @@ -529,7 +529,7 @@ emit_lval_XLP (gcc_jit_lvalue *obj) } static gcc_jit_rvalue * -emit_rval_XUNTAG (gcc_jit_rvalue *a, gcc_jit_type *type, unsigned lisp_word_tag) +emit_XUNTAG (gcc_jit_rvalue *a, gcc_jit_type *type, unsigned lisp_word_tag) { /* #define XUNTAG(a, type, ctype) ((ctype *) ((char *) XLP (a) - LISP_WORD_TAG (type))) */ @@ -540,18 +540,18 @@ emit_rval_XUNTAG (gcc_jit_rvalue *a, gcc_jit_type *type, unsigned lisp_word_tag) NULL, GCC_JIT_BINARY_OP_MINUS, comp.emacs_int_type, - emit_rval_XLI (a), + emit_XLI (a), gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.emacs_int_type, lisp_word_tag))); } static gcc_jit_rvalue * -emit_rval_XCONS (gcc_jit_rvalue *a) +emit_XCONS (gcc_jit_rvalue *a) { - return emit_rval_XUNTAG (a, - gcc_jit_struct_as_type (comp.lisp_cons_s), - LISP_WORD_TAG (Lisp_Cons)); + return emit_XUNTAG (a, + gcc_jit_struct_as_type (comp.lisp_cons_s), + LISP_WORD_TAG (Lisp_Cons)); } static gcc_jit_rvalue * @@ -561,8 +561,8 @@ emit_EQ (gcc_jit_rvalue *x, gcc_jit_rvalue *y) comp.ctxt, NULL, GCC_JIT_COMPARISON_EQ, - emit_rval_XLI (x), - emit_rval_XLI (y)); + emit_XLI (x), + emit_XLI (y)); } static gcc_jit_rvalue * @@ -578,7 +578,7 @@ emit_TAGGEDP (gcc_jit_rvalue *obj, unsigned tag) NULL, GCC_JIT_BINARY_OP_RSHIFT, comp.emacs_int_type, - emit_rval_XLI (obj), + emit_XLI (obj), gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.emacs_int_type, (USE_LSB_TAG ? 0 : VALBITS))); @@ -661,7 +661,7 @@ emit_FIXNUMP (gcc_jit_rvalue *obj) NULL, GCC_JIT_BINARY_OP_RSHIFT, comp.emacs_int_type, - emit_rval_XLI (obj), + emit_XLI (obj), gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.emacs_int_type, (USE_LSB_TAG ? 0 : FIXNUM_BITS))); @@ -703,7 +703,7 @@ emit_XFIXNUM (gcc_jit_rvalue *obj) NULL, GCC_JIT_BINARY_OP_RSHIFT, comp.emacs_int_type, - emit_rval_XLI (obj), + emit_XLI (obj), comp.inttypebits); } @@ -810,7 +810,7 @@ emit_XCAR (gcc_jit_rvalue *c) /* XCONS (c)->u */ gcc_jit_lvalue_as_rvalue ( gcc_jit_rvalue_dereference_field ( - emit_rval_XCONS (c), + emit_XCONS (c), NULL, comp.lisp_cons_u)), NULL, @@ -832,7 +832,7 @@ emit_XCDR (gcc_jit_rvalue *c) /* XCONS (c)->u */ gcc_jit_lvalue_as_rvalue ( gcc_jit_rvalue_dereference_field ( - emit_rval_XCONS (c), + emit_XCONS (c), NULL, comp.lisp_cons_u)), NULL, commit 87ad88622b67ace1e9773a9beb48116d04384c0c Author: Andrea Corallo Date: Fri Jun 28 00:08:23 2019 +0200 add define_CHECK_IMPURE diff --git a/src/comp.c b/src/comp.c index f21e293de6..07b6984acf 100644 --- a/src/comp.c +++ b/src/comp.c @@ -25,6 +25,7 @@ along with GNU Emacs. If not, see . */ #include #include "lisp.h" +#include "puresize.h" #include "buffer.h" #include "bytecode.h" #include "atimer.h" @@ -216,6 +217,8 @@ typedef struct { gcc_jit_field *m_handlerlist; gcc_jit_type *thread_state_ptr_type; gcc_jit_rvalue *current_thread; + /* other globals */ + gcc_jit_rvalue *pure; /* libgccjit has really limited support for casting therefore this union will be used for the scope. */ gcc_jit_type *cast_union_type; @@ -241,6 +244,7 @@ typedef struct { gcc_jit_function *car; gcc_jit_function *cdr; gcc_jit_function *check_type; + gcc_jit_function *check_impure; basic_block_t *block; /* Current basic block */ Lisp_Object func_hash; /* f_name -> gcc_func */ } comp_t; @@ -839,10 +843,40 @@ emit_XCDR (gcc_jit_rvalue *c) comp.lisp_cons_u_s_u_cdr); } -static gcc_jit_rvalue * +static void emit_CHECK_CONS (gcc_jit_rvalue *x) { - return NULL; + gcc_jit_rvalue *args[] = + { emit_CONSP (x), + emit_lisp_obj_from_ptr (comp.block, Qconsp), + x }; + + + gcc_jit_context_new_call (comp.ctxt, + NULL, + comp.check_type, + 3, + args); +} + +static gcc_jit_rvalue * +emit_PURE_P (gcc_jit_rvalue *ptr) +{ + return + gcc_jit_context_new_comparison ( + comp.ctxt, + NULL, + GCC_JIT_COMPARISON_LE, + gcc_jit_context_new_binary_op ( + comp.ctxt, + NULL, + GCC_JIT_BINARY_OP_MINUS, + comp.uintptr_type, + emit_cast (comp.uintptr_type, ptr), + emit_cast (comp.uintptr_type, comp.pure)), + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.uintptr_type, + PURESIZE)); } static gcc_jit_rvalue * @@ -1181,7 +1215,7 @@ define_cast_union (void) } static void -define_check_type (void) +define_CHECK_TYPE (void) { gcc_jit_param *param[] = { gcc_jit_context_new_param (comp.ctxt, @@ -1408,6 +1442,61 @@ define_PSEUDOVECTORP (void) args)); } +static void +define_CHECK_IMPURE (void) +{ + gcc_jit_param *param[] = + { gcc_jit_context_new_param (comp.ctxt, + NULL, + comp.lisp_obj_type, + "obj"), + gcc_jit_context_new_param (comp.ctxt, + NULL, + comp.void_ptr_type, + "ptr") }; + comp.check_impure = + gcc_jit_context_new_function (comp.ctxt, NULL, + GCC_JIT_FUNCTION_ALWAYS_INLINE, + comp.void_type, + "CHECK_IMPURE", + 2, + param, + 0); + gcc_jit_block *initial_block = + gcc_jit_function_new_block (comp.check_impure, + "initial_block"); + gcc_jit_block *err_block = + gcc_jit_function_new_block (comp.check_impure, + "err_block"); + gcc_jit_block *ok_block = + gcc_jit_function_new_block (comp.check_impure, + "ok_block"); + + /* Set current context as needed */ + basic_block_t block = { .gcc_bb = initial_block, + .terminated = false }; + comp.block = █ + comp.func = comp.check_impure; + + emit_cond_jump (emit_cast (comp.bool_type, + emit_PURE_P (gcc_jit_param_as_rvalue (param[0]))), /* FIXME */ + err_block, + ok_block); + gcc_jit_block_end_with_void_return (ok_block, NULL); + + gcc_jit_rvalue *pure_write_error_arg = + gcc_jit_param_as_rvalue (param[0]); + + comp.block->gcc_bb = err_block; + gcc_jit_block_add_eval (comp.block->gcc_bb, + NULL, + emit_call ("pure_write_error", + comp.void_type, 1, + &pure_write_error_arg)); + + gcc_jit_block_end_with_void_return (err_block, NULL); +} + /* Declare a function to convert boolean into t or nil */ static void @@ -1697,17 +1786,22 @@ init_comp (int opt_level) define_handler_struct (); define_thread_state_struct (); define_cast_union (); - define_check_type (); comp.current_thread = gcc_jit_context_new_rvalue_from_ptr (comp.ctxt, comp.thread_state_ptr_type, current_thread); + comp.pure = + gcc_jit_context_new_rvalue_from_ptr (comp.ctxt, + comp.void_ptr_type, + pure); /* Define inline functions. */ define_CAR_CDR(); define_PSEUDOVECTORP (); + define_CHECK_TYPE (); + define_CHECK_IMPURE (); define_bool_to_lisp_obj (); } commit a65545c8905091d90685686f72d7471b61e933e7 Author: Andrea Corallo Date: Fri Jun 28 00:06:57 2019 +0200 make use of gcc_jit_context_get_int_type diff --git a/src/comp.c b/src/comp.c index dc378c0da0..f21e293de6 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1639,12 +1639,9 @@ init_comp (int opt_level) "obj"); #endif - if (sizeof (EMACS_INT) == sizeof (long)) - comp.emacs_int_type = comp.long_type; - else if (sizeof (EMACS_INT) == sizeof (long long)) - comp.emacs_int_type = comp.long_long_type; - else - error ("Unexpected EMACS_INT size."); + comp.emacs_int_type = gcc_jit_context_get_int_type (comp.ctxt, + sizeof (EMACS_INT), + true); comp.lisp_obj_as_num = gcc_jit_context_new_field (comp.ctxt, NULL, @@ -1683,27 +1680,13 @@ init_comp (int opt_level) comp.emacs_int_type, Lisp_Int0); - enum gcc_jit_types ptrdiff_t_gcc; - if (sizeof (ptrdiff_t) == sizeof (int)) - ptrdiff_t_gcc = GCC_JIT_TYPE_INT; - else if (sizeof (ptrdiff_t) == sizeof (long int)) - ptrdiff_t_gcc = GCC_JIT_TYPE_LONG; - else if (sizeof (ptrdiff_t) == sizeof (long long int)) - ptrdiff_t_gcc = GCC_JIT_TYPE_LONG_LONG; - else - eassert ("ptrdiff_t size not handled."); - comp.ptrdiff_type = gcc_jit_context_get_type (comp.ctxt, ptrdiff_t_gcc); - - enum gcc_jit_types uintptr_t_gcc; - if (sizeof (uintptr_t) == sizeof (unsigned)) - uintptr_t_gcc = GCC_JIT_TYPE_UNSIGNED_INT; - else if (sizeof (uintptr_t) == sizeof (unsigned long)) - uintptr_t_gcc = GCC_JIT_TYPE_UNSIGNED_LONG; - else if (sizeof (uintptr_t) == sizeof (unsigned long long)) - uintptr_t_gcc = GCC_JIT_TYPE_UNSIGNED_LONG_LONG; - else - eassert ("uintptr_t size not handled."); - comp.uintptr_type = gcc_jit_context_get_type (comp.ctxt, uintptr_t_gcc); + comp.ptrdiff_type = gcc_jit_context_get_int_type (comp.ctxt, + sizeof (void *), + true); + + comp.uintptr_type = gcc_jit_context_get_int_type (comp.ctxt, + sizeof (void *), + false); comp.func_hash = CALLN (Fmake_hash_table, QCtest, Qequal, QCweakness, Qt); commit 98612a85a50938892b64e1386ec83eeac0fcc2a1 Author: Andrea Corallo Date: Fri Jun 28 00:06:24 2019 +0200 adding more types diff --git a/src/comp.c b/src/comp.c index 309271b8e8..dc378c0da0 100644 --- a/src/comp.c +++ b/src/comp.c @@ -182,7 +182,9 @@ typedef struct { gcc_jit_type *int_type; gcc_jit_type *unsigned_type; gcc_jit_type *long_type; + gcc_jit_type *unsigned_long_type; gcc_jit_type *long_long_type; + gcc_jit_type *unsigned_long_long_type; gcc_jit_type *emacs_int_type; gcc_jit_type *void_ptr_type; gcc_jit_type *char_ptr_type; @@ -218,12 +220,16 @@ typedef struct { be used for the scope. */ gcc_jit_type *cast_union_type; gcc_jit_field *cast_union_as_ll; + gcc_jit_field *cast_union_as_ull; gcc_jit_field *cast_union_as_l; + gcc_jit_field *cast_union_as_ul; gcc_jit_field *cast_union_as_u; gcc_jit_field *cast_union_as_i; gcc_jit_field *cast_union_as_b; gcc_jit_field *cast_union_as_c_p; + gcc_jit_field *cast_union_as_v_p; gcc_jit_field *cast_union_as_lisp_cons_ptr; + gcc_jit_field *cast_union_as_lisp_obj; gcc_jit_function *func; /* Current function being compiled */ gcc_jit_rvalue *most_positive_fixnum; gcc_jit_rvalue *most_negative_fixnum; @@ -297,20 +303,28 @@ type_to_cast_field (gcc_jit_type *type) if (type == comp.long_long_type) field = comp.cast_union_as_ll; + else if (type == comp.unsigned_long_long_type) + field = comp.cast_union_as_ull; else if (type == comp.long_type) field = comp.cast_union_as_l; + else if (type == comp.unsigned_long_type) + field = comp.cast_union_as_ul; else if (type == comp.unsigned_type) field = comp.cast_union_as_u; else if (type == comp.int_type) field = comp.cast_union_as_i; else if (type == comp.bool_type) field = comp.cast_union_as_b; + else if (type == comp.void_ptr_type) + field = comp.cast_union_as_v_p; else if (type == comp.char_ptr_type) field = comp.cast_union_as_c_p; else if (type == comp.lisp_cons_ptr_type) field = comp.cast_union_as_lisp_cons_ptr; + else if (type == comp.lisp_obj_type) + field = comp.cast_union_as_lisp_obj; else - error ("unsopported cast\n"); + error ("unsupported cast\n"); return field; } @@ -1094,11 +1108,21 @@ define_cast_union (void) NULL, comp.long_long_type, "ll"); + comp.cast_union_as_ull = + gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.unsigned_long_long_type, + "ull"); comp.cast_union_as_l = gcc_jit_context_new_field (comp.ctxt, NULL, comp.long_type, "l"); + comp.cast_union_as_ul = + gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.unsigned_long_type, + "ul"); comp.cast_union_as_u = gcc_jit_context_new_field (comp.ctxt, NULL, @@ -1119,20 +1143,34 @@ define_cast_union (void) NULL, comp.char_ptr_type, "c_p"); + comp.cast_union_as_v_p = + gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.void_ptr_type, + "v_p"); comp.cast_union_as_lisp_cons_ptr = gcc_jit_context_new_field (comp.ctxt, NULL, comp.lisp_cons_ptr_type, "cons_ptr"); + comp.cast_union_as_lisp_obj = + gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.lisp_obj_type, + "lisp_obj"); gcc_jit_field *cast_union_fields[] = { comp.cast_union_as_ll, + comp.cast_union_as_ull, comp.cast_union_as_l, + comp.cast_union_as_ul, comp.cast_union_as_u, comp.cast_union_as_i, comp.cast_union_as_b, comp.cast_union_as_c_p, - comp.cast_union_as_lisp_cons_ptr, }; + comp.cast_union_as_v_p, + comp.cast_union_as_lisp_cons_ptr, + comp.cast_union_as_lisp_obj}; comp.cast_union_type = gcc_jit_context_new_union_type (comp.ctxt, NULL, @@ -1573,15 +1611,19 @@ init_comp (int opt_level) comp.void_type = gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_VOID); comp.void_ptr_type = gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_VOID_PTR); + comp.bool_type = gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_BOOL); comp.char_type = gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_CHAR); - comp.char_ptr_type = gcc_jit_type_get_pointer (comp.char_type); comp.int_type = gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_INT); comp.unsigned_type = gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_UNSIGNED_INT); - comp.bool_type = gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_BOOL); comp.long_type = gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_LONG); - comp.long_long_type = gcc_jit_context_get_type (comp.ctxt, - GCC_JIT_TYPE_LONG_LONG); + comp.unsigned_long_type = + gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_UNSIGNED_LONG); + comp.long_long_type = + gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_LONG_LONG); + comp.unsigned_long_long_type = + gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_UNSIGNED_LONG_LONG); + comp.char_ptr_type = gcc_jit_type_get_pointer (comp.char_type); #if EMACS_INT_MAX <= LONG_MAX /* 32-bit builds without wide ints, 64-bit builds on Posix hosts. */ commit c4ec8270ac8694a3ac812a6d1d2bddb6b8fd4c95 Author: Andrea Corallo Date: Wed Jun 26 22:29:39 2019 +0200 rework emit_call_n_ref diff --git a/src/comp.c b/src/comp.c index 5df67fe55f..309271b8e8 100644 --- a/src/comp.c +++ b/src/comp.c @@ -835,12 +835,12 @@ static gcc_jit_rvalue * emit_call_n_ref (const char *f_name, unsigned nargs, gcc_jit_lvalue *base_arg) { - gcc_jit_rvalue *arguments[2] = + gcc_jit_rvalue *args[] = { gcc_jit_context_new_rvalue_from_int(comp.ctxt, - comp.ptrdiff_type, - nargs), + comp.ptrdiff_type, + nargs), gcc_jit_lvalue_get_address (base_arg, NULL) }; - return emit_call (f_name, comp.lisp_obj_type, 2, arguments); + return emit_call (f_name, comp.lisp_obj_type, 2, args); } /* struct Lisp_Cons definition. */ commit 5e3b3e95a9e5b9f269f123fc41f43f411d4c19d9 Author: Andrea Corallo Date: Wed Jun 26 22:28:56 2019 +0200 add uintptr_type diff --git a/src/comp.c b/src/comp.c index 203d476df1..5df67fe55f 100644 --- a/src/comp.c +++ b/src/comp.c @@ -187,6 +187,7 @@ typedef struct { gcc_jit_type *void_ptr_type; gcc_jit_type *char_ptr_type; gcc_jit_type *ptrdiff_type; + gcc_jit_type *uintptr_type; gcc_jit_type *lisp_obj_type; gcc_jit_type *lisp_obj_ptr_type; gcc_jit_field *lisp_obj_as_ptr; @@ -1649,9 +1650,19 @@ init_comp (int opt_level) ptrdiff_t_gcc = GCC_JIT_TYPE_LONG_LONG; else eassert ("ptrdiff_t size not handled."); - comp.ptrdiff_type = gcc_jit_context_get_type (comp.ctxt, ptrdiff_t_gcc); + enum gcc_jit_types uintptr_t_gcc; + if (sizeof (uintptr_t) == sizeof (unsigned)) + uintptr_t_gcc = GCC_JIT_TYPE_UNSIGNED_INT; + else if (sizeof (uintptr_t) == sizeof (unsigned long)) + uintptr_t_gcc = GCC_JIT_TYPE_UNSIGNED_LONG; + else if (sizeof (uintptr_t) == sizeof (unsigned long long)) + uintptr_t_gcc = GCC_JIT_TYPE_UNSIGNED_LONG_LONG; + else + eassert ("uintptr_t size not handled."); + comp.uintptr_type = gcc_jit_context_get_type (comp.ctxt, uintptr_t_gcc); + comp.func_hash = CALLN (Fmake_hash_table, QCtest, Qequal, QCweakness, Qt); /* Define data structures. */ commit 0b7ea165471091d4f998f7bc8cdcda9e27bde531 Author: Andrea Corallo Date: Mon Jun 24 20:23:49 2019 +0200 add define_check_type diff --git a/src/comp.c b/src/comp.c index b6b470c20d..203d476df1 100644 --- a/src/comp.c +++ b/src/comp.c @@ -233,6 +233,7 @@ typedef struct { gcc_jit_function *bool_to_lisp_obj; gcc_jit_function *car; gcc_jit_function *cdr; + gcc_jit_function *check_type; basic_block_t *block; /* Current basic block */ Lisp_Object func_hash; /* f_name -> gcc_func */ } comp_t; @@ -823,6 +824,12 @@ emit_XCDR (gcc_jit_rvalue *c) comp.lisp_cons_u_s_u_cdr); } +static gcc_jit_rvalue * +emit_CHECK_CONS (gcc_jit_rvalue *x) +{ + return NULL; +} + static gcc_jit_rvalue * emit_call_n_ref (const char *f_name, unsigned nargs, gcc_jit_lvalue *base_arg) @@ -1134,6 +1141,66 @@ define_cast_union (void) cast_union_fields); } +static void +define_check_type (void) +{ + gcc_jit_param *param[] = + { gcc_jit_context_new_param (comp.ctxt, + NULL, + comp.int_type, + "ok"), + gcc_jit_context_new_param (comp.ctxt, + NULL, + comp.lisp_obj_type, + "predicate"), + gcc_jit_context_new_param (comp.ctxt, + NULL, + comp.lisp_obj_type, + "x") }; + comp.check_type = + gcc_jit_context_new_function (comp.ctxt, NULL, + GCC_JIT_FUNCTION_ALWAYS_INLINE, + comp.void_type, + "CHECK_TYPE", + 3, + param, + 0); + gcc_jit_rvalue *ok = gcc_jit_param_as_rvalue (param[0]); + gcc_jit_rvalue *predicate = gcc_jit_param_as_rvalue (param[1]); + gcc_jit_rvalue *x = gcc_jit_param_as_rvalue (param[2]); + + gcc_jit_block *initial_block = + gcc_jit_function_new_block (comp.check_type, "initial_block"); + gcc_jit_block *ok_block = + gcc_jit_function_new_block (comp.check_type, "ok_block"); + gcc_jit_block *not_ok_block = + gcc_jit_function_new_block (comp.check_type, "not_ok_block"); + + /* Set current context as needed */ + basic_block_t block = { .gcc_bb = initial_block, + .terminated = false }; + comp.block = █ + comp.func = comp.check_type; + + emit_cond_jump (emit_cast (comp.bool_type, ok), + ok_block, + not_ok_block); + + gcc_jit_block_end_with_void_return (ok_block, NULL); + + comp.block->gcc_bb = not_ok_block; + + gcc_jit_rvalue *wrong_type_args[] = { predicate, x }; + + gcc_jit_block_add_eval (comp.block->gcc_bb, + NULL, + emit_call ("wrong_type_argument", + comp.lisp_obj_type, 2, wrong_type_args)); + + gcc_jit_block_end_with_void_return (not_ok_block, NULL); +} + + /* Declare a substitute for CAR as always inlined function. */ static void @@ -1261,7 +1328,7 @@ define_PSEUDOVECTORP (void) 0); gcc_jit_block *initial_block = - gcc_jit_function_new_block (comp.pseudovectorp, "PSEUDOVECTORP_initial_block"); + gcc_jit_function_new_block (comp.pseudovectorp, "initial_block"); gcc_jit_block *ret_false_b = gcc_jit_function_new_block (comp.pseudovectorp, "ret_false"); @@ -1594,6 +1661,7 @@ init_comp (int opt_level) define_handler_struct (); define_thread_state_struct (); define_cast_union (); + define_check_type (); comp.current_thread = gcc_jit_context_new_rvalue_from_ptr (comp.ctxt, commit 7ca1835309e5aff1fd2454010ee92b3e38069065 Author: Andrea Corallo Date: Mon Jun 24 14:43:50 2019 +0200 inline cdr diff --git a/src/comp.c b/src/comp.c index ab8b4984be..b6b470c20d 100644 --- a/src/comp.c +++ b/src/comp.c @@ -196,6 +196,8 @@ typedef struct { gcc_jit_field *lisp_cons_u; gcc_jit_field *lisp_cons_u_s; gcc_jit_field *lisp_cons_u_s_car; + gcc_jit_field *lisp_cons_u_s_u; + gcc_jit_field *lisp_cons_u_s_u_cdr; gcc_jit_type *lisp_cons_type; gcc_jit_type *lisp_cons_ptr_type; /* struct jmp_buf. */ @@ -230,6 +232,7 @@ typedef struct { gcc_jit_function *pseudovectorp; gcc_jit_function *bool_to_lisp_obj; gcc_jit_function *car; + gcc_jit_function *cdr; basic_block_t *block; /* Current basic block */ Lisp_Object func_hash; /* f_name -> gcc_func */ } comp_t; @@ -779,12 +782,12 @@ emit_NILP (gcc_jit_rvalue *x) static gcc_jit_rvalue * emit_XCAR (gcc_jit_rvalue *c) { - /* XCONS (c)->u.s.car */ + /* XCONS (c)->u.s.car */ return gcc_jit_rvalue_access_field ( - /* c->u.s */ + /* XCONS (c)->u.s */ gcc_jit_rvalue_access_field ( - /* c->u */ + /* XCONS (c)->u */ gcc_jit_lvalue_as_rvalue ( gcc_jit_rvalue_dereference_field ( emit_rval_XCONS (c), @@ -796,6 +799,30 @@ emit_XCAR (gcc_jit_rvalue *c) comp.lisp_cons_u_s_car); } +static gcc_jit_rvalue * +emit_XCDR (gcc_jit_rvalue *c) +{ + /* XCONS (c)->u.s.u.cdr */ + return + gcc_jit_rvalue_access_field ( + /* XCONS (c)->u.s.u */ + gcc_jit_rvalue_access_field ( + /* XCONS (c)->u.s */ + gcc_jit_rvalue_access_field ( + /* XCONS (c)->u */ + gcc_jit_lvalue_as_rvalue ( + gcc_jit_rvalue_dereference_field ( + emit_rval_XCONS (c), + NULL, + comp.lisp_cons_u)), + NULL, + comp.lisp_cons_u_s), + NULL, + comp.lisp_cons_u_s_u), + NULL, + comp.lisp_cons_u_s_u_cdr); +} + static gcc_jit_rvalue * emit_call_n_ref (const char *f_name, unsigned nargs, gcc_jit_lvalue *base_arg) @@ -847,11 +874,14 @@ define_lisp_cons (void) comp.lisp_cons_ptr_type = gcc_jit_type_get_pointer (comp.lisp_cons_type); + comp.lisp_cons_u_s_u_cdr = + gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.lisp_obj_type, + "cdr"); + gcc_jit_field *cdr_u_fields[] = - { gcc_jit_context_new_field (comp.ctxt, - NULL, - comp.lisp_obj_type, - "cdr"), + { comp.lisp_cons_u_s_u_cdr, gcc_jit_context_new_field (comp.ctxt, NULL, comp.lisp_cons_ptr_type, @@ -869,12 +899,13 @@ define_lisp_cons (void) NULL, comp.lisp_obj_type, "car"); + comp.lisp_cons_u_s_u = gcc_jit_context_new_field (comp.ctxt, + NULL, + cdr_u, + "u"); gcc_jit_field *cons_s_fields[] = { comp.lisp_cons_u_s_car, - gcc_jit_context_new_field (comp.ctxt, - NULL, - cdr_u, - "u") }; + comp.lisp_cons_u_s_u }; gcc_jit_struct *cons_s = gcc_jit_context_new_struct_type (comp.ctxt, @@ -1106,77 +1137,103 @@ define_cast_union (void) /* Declare a substitute for CAR as always inlined function. */ static void -define_CAR (void) +define_CAR_CDR (void) { - gcc_jit_param *param = - gcc_jit_context_new_param (comp.ctxt, - NULL, - comp.lisp_obj_type, - "c"); + gcc_jit_param *car_param = + gcc_jit_context_new_param (comp.ctxt, + NULL, + comp.lisp_obj_type, + "c"); comp.car = gcc_jit_context_new_function (comp.ctxt, NULL, GCC_JIT_FUNCTION_ALWAYS_INLINE, comp.lisp_obj_type, "CAR", 1, - ¶m, + &car_param, + 0); + gcc_jit_param *cdr_param = + gcc_jit_context_new_param (comp.ctxt, + NULL, + comp.lisp_obj_type, + "c"); + comp.cdr = + gcc_jit_context_new_function (comp.ctxt, NULL, + GCC_JIT_FUNCTION_ALWAYS_INLINE, + comp.lisp_obj_type, + "CDR", + 1, + &cdr_param, 0); - gcc_jit_rvalue *c = gcc_jit_param_as_rvalue (param); - gcc_jit_block *initial_block = - gcc_jit_function_new_block (comp.car, "initial_block"); - gcc_jit_block *is_cons_b = - gcc_jit_function_new_block (comp.car, "is_cons"); + gcc_jit_function *f = comp.car; + gcc_jit_param *param = car_param; - gcc_jit_block *not_a_cons_b = - gcc_jit_function_new_block (comp.car, "not_a_cons"); + for (int i = 0; i < 2; i++) + { + gcc_jit_rvalue *c = gcc_jit_param_as_rvalue (param); + gcc_jit_block *initial_block = + gcc_jit_function_new_block (f, "initial_block"); + gcc_jit_block *is_cons_b = + gcc_jit_function_new_block (f, "is_cons"); - /* Set current context as needed */ - basic_block_t block = { .gcc_bb = initial_block, - .terminated = false }; - comp.block = █ - comp.func = comp.car; + gcc_jit_block *not_a_cons_b = + gcc_jit_function_new_block (f, "not_a_cons"); - emit_cond_jump ( - emit_cast (comp.bool_type, - emit_CONSP (c)), - is_cons_b, - not_a_cons_b); - comp.block->gcc_bb = is_cons_b; + /* Set current context as needed */ + basic_block_t block = { .gcc_bb = initial_block, + .terminated = false }; + comp.block = █ + comp.func = f; - gcc_jit_block_end_with_return (comp.block->gcc_bb, - NULL, - emit_XCAR (c)); + emit_cond_jump (emit_cast (comp.bool_type, + emit_CONSP (c)), + is_cons_b, + not_a_cons_b); - comp.block->gcc_bb = not_a_cons_b; + comp.block->gcc_bb = is_cons_b; - gcc_jit_block *is_nil_b = - gcc_jit_function_new_block (comp.car, "is_nil"); - gcc_jit_block *not_nil_b = - gcc_jit_function_new_block (comp.car, "not_nil"); + if (f == comp.car) + gcc_jit_block_end_with_return (comp.block->gcc_bb, + NULL, + emit_XCAR (c)); + else + gcc_jit_block_end_with_return (comp.block->gcc_bb, + NULL, + emit_XCDR (c)); - emit_cond_jump (emit_NILP (c), - is_nil_b, - not_nil_b); + comp.block->gcc_bb = not_a_cons_b; - comp.block->gcc_bb = is_nil_b; - gcc_jit_block_end_with_return (comp.block->gcc_bb, - NULL, - emit_lisp_obj_from_ptr (comp.block, Qnil)); + gcc_jit_block *is_nil_b = + gcc_jit_function_new_block (f, "is_nil"); + gcc_jit_block *not_nil_b = + gcc_jit_function_new_block (f, "not_nil"); - comp.block->gcc_bb = not_nil_b; - gcc_jit_rvalue *wrong_type_args[] = - { emit_lisp_obj_from_ptr (comp.block, Qlistp), c }; + emit_cond_jump (emit_NILP (c), + is_nil_b, + not_nil_b); - gcc_jit_block_add_eval (comp.block->gcc_bb, - NULL, - emit_call ("wrong_type_argument", - comp.lisp_obj_type, 2, wrong_type_args)); - gcc_jit_block_end_with_return (comp.block->gcc_bb, - NULL, - emit_lisp_obj_from_ptr (comp.block, Qnil)); + comp.block->gcc_bb = is_nil_b; + gcc_jit_block_end_with_return (comp.block->gcc_bb, + NULL, + emit_lisp_obj_from_ptr (comp.block, Qnil)); + + comp.block->gcc_bb = not_nil_b; + gcc_jit_rvalue *wrong_type_args[] = + { emit_lisp_obj_from_ptr (comp.block, Qlistp), c }; + + gcc_jit_block_add_eval (comp.block->gcc_bb, + NULL, + emit_call ("wrong_type_argument", + comp.lisp_obj_type, 2, wrong_type_args)); + gcc_jit_block_end_with_return (comp.block->gcc_bb, + NULL, + emit_lisp_obj_from_ptr (comp.block, Qnil)); + f = comp.cdr; + param = cdr_param; + } } /* Declare a substitute for PSEUDOVECTORP as always inlined function. */ @@ -1545,7 +1602,7 @@ init_comp (int opt_level) /* Define inline functions. */ - define_CAR(); + define_CAR_CDR(); define_PSEUDOVECTORP (); define_bool_to_lisp_obj (); } @@ -1971,7 +2028,15 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, PUSH_RVAL (res); break; - CASE_CALL_N (cdr, 1); + case Bcdr: + POP1; + res = gcc_jit_context_new_call (comp.ctxt, + NULL, + comp.cdr, + 1, args); + PUSH_RVAL (res); + break; + CASE_CALL_N (cons, 2); CASE (BlistN) commit 09b89741d038b0f60aa0623f8263a0d2d89c7174 Author: Andrea Corallo Date: Mon Jun 24 14:13:01 2019 +0200 split XCAR diff --git a/src/comp.c b/src/comp.c index e3ec34d554..ab8b4984be 100644 --- a/src/comp.c +++ b/src/comp.c @@ -776,6 +776,26 @@ emit_NILP (gcc_jit_rvalue *x) return emit_EQ (x, emit_lisp_obj_from_ptr (comp.block, Qnil)); } +static gcc_jit_rvalue * +emit_XCAR (gcc_jit_rvalue *c) +{ + /* XCONS (c)->u.s.car */ + return + gcc_jit_rvalue_access_field ( + /* c->u.s */ + gcc_jit_rvalue_access_field ( + /* c->u */ + gcc_jit_lvalue_as_rvalue ( + gcc_jit_rvalue_dereference_field ( + emit_rval_XCONS (c), + NULL, + comp.lisp_cons_u)), + NULL, + comp.lisp_cons_u_s), + NULL, + comp.lisp_cons_u_s_car); +} + static gcc_jit_rvalue * emit_call_n_ref (const char *f_name, unsigned nargs, gcc_jit_lvalue *base_arg) @@ -1103,7 +1123,7 @@ define_CAR (void) 0); gcc_jit_rvalue *c = gcc_jit_param_as_rvalue (param); gcc_jit_block *initial_block = - gcc_jit_function_new_block (comp.car, "CAR_initial_block"); + gcc_jit_function_new_block (comp.car, "initial_block"); gcc_jit_block *is_cons_b = gcc_jit_function_new_block (comp.car, "is_cons"); @@ -1126,25 +1146,9 @@ define_CAR (void) comp.block->gcc_bb = is_cons_b; - gcc_jit_rvalue *res_car = - /* c->u.s.car */ - gcc_jit_rvalue_access_field ( - /* c->u.s */ - gcc_jit_rvalue_access_field ( - /* c->u */ - gcc_jit_lvalue_as_rvalue ( - gcc_jit_rvalue_dereference_field ( - emit_rval_XCONS (c), - NULL, - comp.lisp_cons_u)), - NULL, - comp.lisp_cons_u_s), - NULL, - comp.lisp_cons_u_s_car); - gcc_jit_block_end_with_return (comp.block->gcc_bb, NULL, - res_car); + emit_XCAR (c)); comp.block->gcc_bb = not_a_cons_b; commit 57ac14e3e27adb09629b5547101295fae44f8847 Author: Andrea Corallo Date: Mon Jun 24 14:07:59 2019 +0200 add car cdr tests diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 6a7370a880..31b2f0f001 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -32,7 +32,7 @@ (defvar comp-tests-var1 3) (ert-deftest comp-tests-varref () - "Testing cons car cdr." + "Testing varref." (defun comp-tests-varref-f () comp-tests-var1) @@ -45,6 +45,12 @@ "Testing cons car cdr." (defun comp-tests-list-f () (list 1 2 3)) + (defun comp-tests-car-f (x) + ;; Bcar + (car x)) + (defun comp-tests-cdr-f (x) + ;; Bcdr + (cdr x)) (defun comp-tests-car-safe-f (x) ;; Bcar_safe (car-safe x)) @@ -54,12 +60,28 @@ (byte-compile #'comp-tests-list-f) (native-compile #'comp-tests-list-f) + (byte-compile #'comp-tests-car-f) + (native-compile #'comp-tests-car-f) + (byte-compile #'comp-tests-cdr-f) + (native-compile #'comp-tests-cdr-f) (byte-compile #'comp-tests-car-safe-f) (native-compile #'comp-tests-car-safe-f) (byte-compile #'comp-tests-cdr-safe-f) (native-compile #'comp-tests-cdr-safe-f) (should (equal (comp-tests-list-f) '(1 2 3))) + (should (= (comp-tests-car-f '(1 . 2)) 1)) + (should (null (comp-tests-car-f nil))) + (should (= (condition-case err + (comp-tests-car-f 3) + (error 10)) + 10)) + (should (= (comp-tests-cdr-f '(1 . 2)) 2)) + (should (null (comp-tests-cdr-f nil))) + (should (= (condition-case err + (comp-tests-cdr-f 3) + (error 10)) + 10)) (should (= (comp-tests-car-safe-f '(1 . 2)) 1)) (should (null (comp-tests-car-safe-f 'a))) (should (= (comp-tests-cdr-safe-f '(1 . 2)) 2)) commit df93780efe61cea82463a96dbac3792fd3eed737 Author: Andrea Corallo Date: Mon Jun 24 13:47:08 2019 +0200 full inline car diff --git a/src/comp.c b/src/comp.c index 599f8f158b..e3ec34d554 100644 --- a/src/comp.c +++ b/src/comp.c @@ -194,7 +194,10 @@ typedef struct { /* struct Lisp_Cons */ gcc_jit_struct *lisp_cons_s; gcc_jit_field *lisp_cons_u; - gcc_jit_type *lisp_cons_ptr; + gcc_jit_field *lisp_cons_u_s; + gcc_jit_field *lisp_cons_u_s_car; + gcc_jit_type *lisp_cons_type; + gcc_jit_type *lisp_cons_ptr_type; /* struct jmp_buf. */ gcc_jit_struct *jmp_buf_s; /* struct handler. */ @@ -217,6 +220,7 @@ typedef struct { gcc_jit_field *cast_union_as_i; gcc_jit_field *cast_union_as_b; gcc_jit_field *cast_union_as_c_p; + gcc_jit_field *cast_union_as_lisp_cons_ptr; gcc_jit_function *func; /* Current function being compiled */ gcc_jit_rvalue *most_positive_fixnum; gcc_jit_rvalue *most_negative_fixnum; @@ -225,6 +229,7 @@ typedef struct { gcc_jit_rvalue *lisp_int0; gcc_jit_function *pseudovectorp; gcc_jit_function *bool_to_lisp_obj; + gcc_jit_function *car; basic_block_t *block; /* Current basic block */ Lisp_Object func_hash; /* f_name -> gcc_func */ } comp_t; @@ -297,6 +302,8 @@ type_to_cast_field (gcc_jit_type *type) field = comp.cast_union_as_b; else if (type == comp.char_ptr_type) field = comp.cast_union_as_c_p; + else if (type == comp.lisp_cons_ptr_type) + field = comp.cast_union_as_lisp_cons_ptr; else error ("unsopported cast\n"); @@ -768,6 +775,8 @@ emit_NILP (gcc_jit_rvalue *x) { return emit_EQ (x, emit_lisp_obj_from_ptr (comp.block, Qnil)); } + +static gcc_jit_rvalue * emit_call_n_ref (const char *f_name, unsigned nargs, gcc_jit_lvalue *base_arg) { @@ -813,8 +822,10 @@ define_lisp_cons (void) gcc_jit_context_new_opaque_struct (comp.ctxt, NULL, "comp_Lisp_Cons"); - comp.lisp_cons_ptr = - gcc_jit_type_get_pointer (gcc_jit_struct_as_type (comp.lisp_cons_s)); + comp.lisp_cons_type = + gcc_jit_struct_as_type (comp.lisp_cons_s); + comp.lisp_cons_ptr_type = + gcc_jit_type_get_pointer (comp.lisp_cons_type); gcc_jit_field *cdr_u_fields[] = { gcc_jit_context_new_field (comp.ctxt, @@ -823,7 +834,7 @@ define_lisp_cons (void) "cdr"), gcc_jit_context_new_field (comp.ctxt, NULL, - comp.lisp_cons_ptr, + comp.lisp_cons_ptr_type, "chain") }; gcc_jit_type *cdr_u = @@ -834,11 +845,12 @@ define_lisp_cons (void) / sizeof (*cdr_u_fields), cdr_u_fields); + comp.lisp_cons_u_s_car = gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.lisp_obj_type, + "car"); gcc_jit_field *cons_s_fields[] = - { gcc_jit_context_new_field (comp.ctxt, - NULL, - comp.lisp_obj_type, - "car"), + { comp.lisp_cons_u_s_car, gcc_jit_context_new_field (comp.ctxt, NULL, cdr_u, @@ -852,11 +864,13 @@ define_lisp_cons (void) / sizeof (*cons_s_fields), cons_s_fields); - gcc_jit_field *cons_u_fields[] = - { gcc_jit_context_new_field (comp.ctxt, + comp.lisp_cons_u_s = gcc_jit_context_new_field (comp.ctxt, NULL, gcc_jit_struct_as_type (cons_s), - "s"), + "s"); + + gcc_jit_field *cons_u_fields[] = + { comp.lisp_cons_u_s, gcc_jit_context_new_field ( comp.ctxt, NULL, @@ -866,7 +880,7 @@ define_lisp_cons (void) sizeof (struct Lisp_Cons)), "align_pad") }; - gcc_jit_type *cons_u = + gcc_jit_type *lisp_cons_u_type = gcc_jit_context_new_union_type (comp.ctxt, NULL, "comp_cons_u", @@ -877,7 +891,7 @@ define_lisp_cons (void) comp.lisp_cons_u = gcc_jit_context_new_field (comp.ctxt, NULL, - cons_u, + lisp_cons_u_type, "u"); gcc_jit_struct_set_fields (comp.lisp_cons_s, NULL, 1, &comp.lisp_cons_u); @@ -1087,29 +1101,30 @@ define_CAR (void) 1, ¶m, 0); + gcc_jit_rvalue *c = gcc_jit_param_as_rvalue (param); gcc_jit_block *initial_block = gcc_jit_function_new_block (comp.car, "CAR_initial_block"); - /* gcc_jit_block *is_cons_b = */ - /* gcc_jit_function_new_block (comp.pseudovectorp, "is_cons"); */ + gcc_jit_block *is_cons_b = + gcc_jit_function_new_block (comp.car, "is_cons"); - /* gcc_jit_block *not_a_cons_b = */ - /* gcc_jit_function_new_block (comp.pseudovectorp, "not_a_cons"); */ + gcc_jit_block *not_a_cons_b = + gcc_jit_function_new_block (comp.car, "not_a_cons"); /* Set current context as needed */ basic_block_t block = { .gcc_bb = initial_block, - .terminated = false }; + .terminated = false }; comp.block = █ comp.func = comp.car; - /* emit_cond_jump ( */ - /* emit_cast (comp.bool_type, */ - /* emit_CONSP (gcc_jit_param_as_rvalue (param))), */ - /* is_cons_b, */ - /* not_a_cons_b); */ + emit_cond_jump ( + emit_cast (comp.bool_type, + emit_CONSP (c)), + is_cons_b, + not_a_cons_b); - /* comp.block->gcc_bb = is_cons_b; */ + comp.block->gcc_bb = is_cons_b; gcc_jit_rvalue *res_car = /* c->u.s.car */ @@ -1119,7 +1134,7 @@ define_CAR (void) /* c->u */ gcc_jit_lvalue_as_rvalue ( gcc_jit_rvalue_dereference_field ( - emit_rval_XCONS (gcc_jit_param_as_rvalue (param)), + emit_rval_XCONS (c), NULL, comp.lisp_cons_u)), NULL, @@ -1127,10 +1142,37 @@ define_CAR (void) NULL, comp.lisp_cons_u_s_car); - gcc_jit_block_end_with_return (initial_block, + gcc_jit_block_end_with_return (comp.block->gcc_bb, NULL, res_car); + comp.block->gcc_bb = not_a_cons_b; + + gcc_jit_block *is_nil_b = + gcc_jit_function_new_block (comp.car, "is_nil"); + gcc_jit_block *not_nil_b = + gcc_jit_function_new_block (comp.car, "not_nil"); + + emit_cond_jump (emit_NILP (c), + is_nil_b, + not_nil_b); + + comp.block->gcc_bb = is_nil_b; + gcc_jit_block_end_with_return (comp.block->gcc_bb, + NULL, + emit_lisp_obj_from_ptr (comp.block, Qnil)); + + comp.block->gcc_bb = not_nil_b; + gcc_jit_rvalue *wrong_type_args[] = + { emit_lisp_obj_from_ptr (comp.block, Qlistp), c }; + + gcc_jit_block_add_eval (comp.block->gcc_bb, + NULL, + emit_call ("wrong_type_argument", + comp.lisp_obj_type, 2, wrong_type_args)); + gcc_jit_block_end_with_return (comp.block->gcc_bb, + NULL, + emit_lisp_obj_from_ptr (comp.block, Qnil)); } /* Declare a substitute for PSEUDOVECTORP as always inlined function. */ @@ -1496,6 +1538,10 @@ init_comp (int opt_level) gcc_jit_context_new_rvalue_from_ptr (comp.ctxt, comp.thread_state_ptr_type, current_thread); + + /* Define inline functions. */ + + define_CAR(); define_PSEUDOVECTORP (); define_bool_to_lisp_obj (); } @@ -1911,7 +1957,16 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, CASE_CALL_N (eq, 2); CASE_CALL_N (memq, 1); CASE_CALL_N (not, 1); - CASE_CALL_N (car, 1); + + case Bcar: + POP1; + res = gcc_jit_context_new_call (comp.ctxt, + NULL, + comp.car, + 1, args); + PUSH_RVAL (res); + break; + CASE_CALL_N (cdr, 1); CASE_CALL_N (cons, 2); commit a8c60ea884b835b7a109b735ee82600c7c785c5d Author: Andrea Corallo Date: Mon Jun 24 13:45:44 2019 +0200 fix XUNTAG diff --git a/src/comp.c b/src/comp.c index 6f5ca5f4ec..599f8f158b 100644 --- a/src/comp.c +++ b/src/comp.c @@ -504,7 +504,7 @@ emit_rval_XUNTAG (gcc_jit_rvalue *a, gcc_jit_type *type, unsigned lisp_word_tag) /* #define XUNTAG(a, type, ctype) ((ctype *) ((char *) XLP (a) - LISP_WORD_TAG (type))) */ - return emit_cast (type, + return emit_cast (gcc_jit_type_get_pointer (type), gcc_jit_context_new_binary_op ( comp.ctxt, NULL, @@ -512,8 +512,10 @@ emit_rval_XUNTAG (gcc_jit_rvalue *a, gcc_jit_type *type, unsigned lisp_word_tag) comp.emacs_int_type, emit_rval_XLI (a), gcc_jit_context_new_rvalue_from_int (comp.ctxt, - comp.int_type, - lisp_word_tag))); + comp.emacs_int_type, + lisp_word_tag))); +} + static gcc_jit_rvalue * emit_rval_XCONS (gcc_jit_rvalue *a) { commit 4d4f2a4efc8fb58d8b3375578b763aee33b6e91a Author: Andrea Corallo Date: Mon Jun 24 13:45:08 2019 +0200 add emit_EQ diff --git a/src/comp.c b/src/comp.c index 4f3a80572d..6f5ca5f4ec 100644 --- a/src/comp.c +++ b/src/comp.c @@ -522,6 +522,15 @@ emit_rval_XCONS (gcc_jit_rvalue *a) LISP_WORD_TAG (Lisp_Cons)); } +static gcc_jit_rvalue * +emit_EQ (gcc_jit_rvalue *x, gcc_jit_rvalue *y) +{ + return gcc_jit_context_new_comparison ( + comp.ctxt, + NULL, + GCC_JIT_COMPARISON_EQ, + emit_rval_XLI (x), + emit_rval_XLI (y)); } static gcc_jit_rvalue * commit 2dc6ff917607f5444417884662126ad0d4037402 Author: Andrea Corallo Date: Mon Jun 24 13:44:25 2019 +0200 add emit_NILP diff --git a/src/comp.c b/src/comp.c index e1fb731631..4f3a80572d 100644 --- a/src/comp.c +++ b/src/comp.c @@ -753,6 +753,10 @@ emit_lisp_obj_from_ptr (basic_block_t *block, void *p) } static gcc_jit_rvalue * +emit_NILP (gcc_jit_rvalue *x) +{ + return emit_EQ (x, emit_lisp_obj_from_ptr (comp.block, Qnil)); +} emit_call_n_ref (const char *f_name, unsigned nargs, gcc_jit_lvalue *base_arg) { commit 6955ca3d2a0a2269bd0f4578b560c58ca62efeb1 Author: Andrea Corallo Date: Mon Jun 24 13:43:58 2019 +0200 add emit_rval_XCONS diff --git a/src/comp.c b/src/comp.c index c24017ce68..e1fb731631 100644 --- a/src/comp.c +++ b/src/comp.c @@ -514,6 +514,14 @@ emit_rval_XUNTAG (gcc_jit_rvalue *a, gcc_jit_type *type, unsigned lisp_word_tag) gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.int_type, lisp_word_tag))); +static gcc_jit_rvalue * +emit_rval_XCONS (gcc_jit_rvalue *a) +{ + return emit_rval_XUNTAG (a, + gcc_jit_struct_as_type (comp.lisp_cons_s), + LISP_WORD_TAG (Lisp_Cons)); +} + } static gcc_jit_rvalue * commit 4f5881bc0ce56ef6d11506508e69451031e378b8 Author: Andrea Corallo Date: Mon Jun 24 12:25:15 2019 +0200 better emit_cast diff --git a/src/comp.c b/src/comp.c index 38183a64e2..c24017ce68 100644 --- a/src/comp.c +++ b/src/comp.c @@ -443,6 +443,8 @@ emit_comparison_jump (enum gcc_jit_comparison op, /* TODO add basick block as pa static gcc_jit_rvalue * emit_cast (gcc_jit_type *new_type, gcc_jit_rvalue *obj) { + static unsigned i; + gcc_jit_field *orig_field = type_to_cast_field (gcc_jit_rvalue_get_type (obj)); gcc_jit_field *dest_field = type_to_cast_field (new_type); @@ -451,7 +453,7 @@ emit_cast (gcc_jit_type *new_type, gcc_jit_rvalue *obj) gcc_jit_function_new_local (comp.func, NULL, comp.cast_union_type, - "union_cast"); + format_string ("union_cast_%u", i++)); gcc_jit_block_add_assignment (comp.block->gcc_bb, NULL, gcc_jit_lvalue_access_field (tmp_u, commit c4bebcb38fe426780fc9c460474592d12bc15deb Author: Andrea Corallo Date: Mon Jun 24 12:24:50 2019 +0200 define cast union into dedicated function diff --git a/src/comp.c b/src/comp.c index 9ef1a99b0f..38183a64e2 100644 --- a/src/comp.c +++ b/src/comp.c @@ -987,7 +987,128 @@ define_thread_state_struct (void) gcc_jit_type_get_pointer (gcc_jit_struct_as_type (comp.thread_state_s)); } -/* Declare a substitute for PSEUDOVECTORP as inline function. */ +static void +define_cast_union (void) +{ + + comp.cast_union_as_ll = + gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.long_long_type, + "ll"); + comp.cast_union_as_l = + gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.long_type, + "l"); + comp.cast_union_as_u = + gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.unsigned_type, + "u"); + comp.cast_union_as_i = + gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.int_type, + "i"); + comp.cast_union_as_b = + gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.bool_type, + "b"); + comp.cast_union_as_c_p = + gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.char_ptr_type, + "c_p"); + comp.cast_union_as_lisp_cons_ptr = + gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.lisp_cons_ptr_type, + "cons_ptr"); + + gcc_jit_field *cast_union_fields[] = + { comp.cast_union_as_ll, + comp.cast_union_as_l, + comp.cast_union_as_u, + comp.cast_union_as_i, + comp.cast_union_as_b, + comp.cast_union_as_c_p, + comp.cast_union_as_lisp_cons_ptr, }; + comp.cast_union_type = + gcc_jit_context_new_union_type (comp.ctxt, + NULL, + "cast_union", + sizeof (cast_union_fields) + / sizeof (*cast_union_fields), + cast_union_fields); +} + +/* Declare a substitute for CAR as always inlined function. */ + +static void +define_CAR (void) +{ + gcc_jit_param *param = + gcc_jit_context_new_param (comp.ctxt, + NULL, + comp.lisp_obj_type, + "c"); + comp.car = + gcc_jit_context_new_function (comp.ctxt, NULL, + GCC_JIT_FUNCTION_ALWAYS_INLINE, + comp.lisp_obj_type, + "CAR", + 1, + ¶m, + 0); + gcc_jit_block *initial_block = + gcc_jit_function_new_block (comp.car, "CAR_initial_block"); + + /* gcc_jit_block *is_cons_b = */ + /* gcc_jit_function_new_block (comp.pseudovectorp, "is_cons"); */ + + /* gcc_jit_block *not_a_cons_b = */ + /* gcc_jit_function_new_block (comp.pseudovectorp, "not_a_cons"); */ + + + /* Set current context as needed */ + basic_block_t block = { .gcc_bb = initial_block, + .terminated = false }; + comp.block = █ + comp.func = comp.car; + + /* emit_cond_jump ( */ + /* emit_cast (comp.bool_type, */ + /* emit_CONSP (gcc_jit_param_as_rvalue (param))), */ + /* is_cons_b, */ + /* not_a_cons_b); */ + + /* comp.block->gcc_bb = is_cons_b; */ + + gcc_jit_rvalue *res_car = + /* c->u.s.car */ + gcc_jit_rvalue_access_field ( + /* c->u.s */ + gcc_jit_rvalue_access_field ( + /* c->u */ + gcc_jit_lvalue_as_rvalue ( + gcc_jit_rvalue_dereference_field ( + emit_rval_XCONS (gcc_jit_param_as_rvalue (param)), + NULL, + comp.lisp_cons_u)), + NULL, + comp.lisp_cons_u_s), + NULL, + comp.lisp_cons_u_s_car); + + gcc_jit_block_end_with_return (initial_block, + NULL, + res_car); + +} + +/* Declare a substitute for PSEUDOVECTORP as always inlined function. */ static void define_PSEUDOVECTORP (void) @@ -1022,7 +1143,7 @@ define_PSEUDOVECTORP (void) /* Set current context as needed */ basic_block_t block = { .gcc_bb = initial_block, - .terminated = false }; + .terminated = false }; comp.block = █ comp.func = comp.pseudovectorp; @@ -1044,7 +1165,7 @@ define_PSEUDOVECTORP (void) { gcc_jit_param_as_rvalue (param[0]), gcc_jit_param_as_rvalue (param[1]) }; comp.block->gcc_bb = call_pseudovector_typep_b; - /* FIXME XUNTAG missing here. */ + /* FIXME use XUNTAG now that's available. */ gcc_jit_block_end_with_return (call_pseudovector_typep_b, NULL, emit_call ("helper_PSEUDOVECTOR_TYPEP_XUNTAG", @@ -1302,51 +1423,6 @@ init_comp (int opt_level) lisp_obj_fields); comp.lisp_obj_ptr_type = gcc_jit_type_get_pointer (comp.lisp_obj_type); - comp.cast_union_as_ll = - gcc_jit_context_new_field (comp.ctxt, - NULL, - comp.long_long_type, - "ll"); - comp.cast_union_as_l = - gcc_jit_context_new_field (comp.ctxt, - NULL, - comp.long_type, - "l"); - comp.cast_union_as_u = - gcc_jit_context_new_field (comp.ctxt, - NULL, - comp.unsigned_type, - "u"); - comp.cast_union_as_i = - gcc_jit_context_new_field (comp.ctxt, - NULL, - comp.int_type, - "i"); - comp.cast_union_as_b = - gcc_jit_context_new_field (comp.ctxt, - NULL, - comp.bool_type, - "b"); - comp.cast_union_as_c_p = - gcc_jit_context_new_field (comp.ctxt, - NULL, - comp.bool_type, - "c_p"); - - gcc_jit_field *cast_union_fields[] = - { comp.cast_union_as_ll, - comp.cast_union_as_l, - comp.cast_union_as_u, - comp.cast_union_as_i, - comp.cast_union_as_b, - comp.cast_union_as_c_p, }; - comp.cast_union_type = - gcc_jit_context_new_union_type (comp.ctxt, - NULL, - "cast_union", - sizeof (cast_union_fields) - / sizeof (*cast_union_fields), - cast_union_fields); comp.most_positive_fixnum = gcc_jit_context_new_rvalue_from_long (comp.ctxt, comp.emacs_int_type, @@ -1383,10 +1459,14 @@ init_comp (int opt_level) comp.func_hash = CALLN (Fmake_hash_table, QCtest, Qequal, QCweakness, Qt); + /* Define data structures. */ + define_lisp_cons (); define_jmp_buf (); define_handler_struct (); define_thread_state_struct (); + define_cast_union (); + comp.current_thread = gcc_jit_context_new_rvalue_from_ptr (comp.ctxt, comp.thread_state_ptr_type, commit fc2e2818edc0eaa4b86124d102eb12b7a24fa486 Author: Andrea Corallo Date: Mon Jun 24 11:34:27 2019 +0200 reindent define_thread_state_struct diff --git a/src/comp.c b/src/comp.c index f754778468..9ef1a99b0f 100644 --- a/src/comp.c +++ b/src/comp.c @@ -967,13 +967,14 @@ define_thread_state_struct (void) gcc_jit_context_new_field ( comp.ctxt, NULL, - gcc_jit_context_new_array_type (comp.ctxt, - NULL, - comp.char_type, - sizeof (struct thread_state) - - offsetof (struct thread_state, - m_handlerlist) - - sizeof (((struct thread_state *) 0)->m_handlerlist)), + gcc_jit_context_new_array_type ( + comp.ctxt, + NULL, + comp.char_type, + sizeof (struct thread_state) + - offsetof (struct thread_state, + m_handlerlist) + - sizeof (((struct thread_state *) 0)->m_handlerlist)), "pad1") }; comp.thread_state_s = commit 483a2d39df48ef17f446f4c41171654a10ce62b2 Author: Andrea Corallo Date: Mon Jun 24 11:33:44 2019 +0200 add XUNTAG diff --git a/src/comp.c b/src/comp.c index 2bffba0833..f754778468 100644 --- a/src/comp.c +++ b/src/comp.c @@ -496,6 +496,24 @@ emit_lval_XLP (gcc_jit_lvalue *obj) comp.lisp_obj_as_ptr); } +static gcc_jit_rvalue * +emit_rval_XUNTAG (gcc_jit_rvalue *a, gcc_jit_type *type, unsigned lisp_word_tag) +{ + /* #define XUNTAG(a, type, ctype) ((ctype *) + ((char *) XLP (a) - LISP_WORD_TAG (type))) */ + + return emit_cast (type, + gcc_jit_context_new_binary_op ( + comp.ctxt, + NULL, + GCC_JIT_BINARY_OP_MINUS, + comp.emacs_int_type, + emit_rval_XLI (a), + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.int_type, + lisp_word_tag))); +} + static gcc_jit_rvalue * emit_TAGGEDP (gcc_jit_rvalue *obj, unsigned tag) { commit f2dd0cb80fc283293ef64e07d79b06609058e216 Author: Andrea Corallo Date: Mon Jun 24 11:32:11 2019 +0200 add char * type support diff --git a/src/comp.c b/src/comp.c index e1a7b25bb2..2bffba0833 100644 --- a/src/comp.c +++ b/src/comp.c @@ -185,6 +185,7 @@ typedef struct { gcc_jit_type *long_long_type; gcc_jit_type *emacs_int_type; gcc_jit_type *void_ptr_type; + gcc_jit_type *char_ptr_type; gcc_jit_type *ptrdiff_type; gcc_jit_type *lisp_obj_type; gcc_jit_type *lisp_obj_ptr_type; @@ -215,6 +216,7 @@ typedef struct { gcc_jit_field *cast_union_as_u; gcc_jit_field *cast_union_as_i; gcc_jit_field *cast_union_as_b; + gcc_jit_field *cast_union_as_c_p; gcc_jit_function *func; /* Current function being compiled */ gcc_jit_rvalue *most_positive_fixnum; gcc_jit_rvalue *most_negative_fixnum; @@ -293,6 +295,8 @@ type_to_cast_field (gcc_jit_type *type) field = comp.cast_union_as_i; else if (type == comp.bool_type) field = comp.cast_union_as_b; + else if (type == comp.char_ptr_type) + field = comp.cast_union_as_c_p; else error ("unsopported cast\n"); @@ -1234,6 +1238,7 @@ init_comp (int opt_level) comp.void_ptr_type = gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_VOID_PTR); comp.char_type = gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_CHAR); + comp.char_ptr_type = gcc_jit_type_get_pointer (comp.char_type); comp.int_type = gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_INT); comp.unsigned_type = gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_UNSIGNED_INT); @@ -1303,13 +1308,19 @@ init_comp (int opt_level) NULL, comp.bool_type, "b"); + comp.cast_union_as_c_p = + gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.bool_type, + "c_p"); gcc_jit_field *cast_union_fields[] = { comp.cast_union_as_ll, comp.cast_union_as_l, comp.cast_union_as_u, comp.cast_union_as_i, - comp.cast_union_as_b,}; + comp.cast_union_as_b, + comp.cast_union_as_c_p, }; comp.cast_union_type = gcc_jit_context_new_union_type (comp.ctxt, NULL, commit 4577eeedf620a739a66e69204b40da8cdbbd77e0 Author: Andrea Corallo Date: Mon Jun 24 10:05:22 2019 +0200 better options diff --git a/src/comp.c b/src/comp.c index b4bcd51190..e1a7b25bb2 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1205,9 +1205,6 @@ init_comp (int opt_level) gcc_jit_context_set_logfile (comp.ctxt, logfile, 0, 0); - gcc_jit_context_set_bool_option (comp.ctxt, - GCC_JIT_BOOL_OPTION_DUMP_EVERYTHING, - 1); gcc_jit_context_set_bool_option (comp.ctxt, GCC_JIT_BOOL_OPTION_KEEP_INTERMEDIATES, 1); @@ -1217,6 +1214,9 @@ init_comp (int opt_level) gcc_jit_context_set_bool_option (comp.ctxt, GCC_JIT_BOOL_OPTION_DEBUGINFO, 1); + gcc_jit_context_set_bool_option (comp.ctxt, + GCC_JIT_BOOL_OPTION_DUMP_INITIAL_GIMPLE, + 1); gcc_jit_context_dump_reproducer_to_file (comp.ctxt, "comp_reproducer.c"); @@ -1226,6 +1226,10 @@ init_comp (int opt_level) GCC_JIT_INT_OPTION_OPTIMIZATION_LEVEL, opt_level); + /* Do not inline within a compilation unit. */ + gcc_jit_context_add_command_line_option (comp.ctxt, "-fno-inline"); + + comp.void_type = gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_VOID); comp.void_ptr_type = gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_VOID_PTR); commit fdc8de36c3b6c5c294bbf4be61f4239ac822aa11 Author: Andrea Corallo Date: Sun Jun 23 20:50:05 2019 +0200 add cons definition diff --git a/src/comp.c b/src/comp.c index ca78d9317d..b4bcd51190 100644 --- a/src/comp.c +++ b/src/comp.c @@ -190,6 +190,10 @@ typedef struct { gcc_jit_type *lisp_obj_ptr_type; gcc_jit_field *lisp_obj_as_ptr; gcc_jit_field *lisp_obj_as_num; + /* struct Lisp_Cons */ + gcc_jit_struct *lisp_cons_s; + gcc_jit_field *lisp_cons_u; + gcc_jit_type *lisp_cons_ptr; /* struct jmp_buf. */ gcc_jit_struct *jmp_buf_s; /* struct handler. */ @@ -728,7 +732,112 @@ emit_call_n_ref (const char *f_name, unsigned nargs, return emit_call (f_name, comp.lisp_obj_type, 2, arguments); } -/* opaque jmp_buf definition */ +/* struct Lisp_Cons definition. */ + +static void +define_lisp_cons (void) +{ + /* + union cdr_u + { + Lisp_Object cdr; + struct Lisp_Cons *chain; + }; + + struct cons_s + { + Lisp_Object car; + union cdr_u u; + }; + + union cons_u + { + struct cons_s s; + char align_pad[sizeof (struct Lisp_Cons)]; + }; + + struct Lisp_Cons + { + union cons_u u; + }; + */ + + comp.lisp_cons_s = + gcc_jit_context_new_opaque_struct (comp.ctxt, + NULL, + "comp_Lisp_Cons"); + comp.lisp_cons_ptr = + gcc_jit_type_get_pointer (gcc_jit_struct_as_type (comp.lisp_cons_s)); + + gcc_jit_field *cdr_u_fields[] = + { gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.lisp_obj_type, + "cdr"), + gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.lisp_cons_ptr, + "chain") }; + + gcc_jit_type *cdr_u = + gcc_jit_context_new_union_type (comp.ctxt, + NULL, + "comp_cdr_u", + sizeof (cdr_u_fields) + / sizeof (*cdr_u_fields), + cdr_u_fields); + + gcc_jit_field *cons_s_fields[] = + { gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.lisp_obj_type, + "car"), + gcc_jit_context_new_field (comp.ctxt, + NULL, + cdr_u, + "u") }; + + gcc_jit_struct *cons_s = + gcc_jit_context_new_struct_type (comp.ctxt, + NULL, + "comp_cons_s", + sizeof (cons_s_fields) + / sizeof (*cons_s_fields), + cons_s_fields); + + gcc_jit_field *cons_u_fields[] = + { gcc_jit_context_new_field (comp.ctxt, + NULL, + gcc_jit_struct_as_type (cons_s), + "s"), + gcc_jit_context_new_field ( + comp.ctxt, + NULL, + gcc_jit_context_new_array_type (comp.ctxt, + NULL, + comp.char_type, + sizeof (struct Lisp_Cons)), + "align_pad") }; + + gcc_jit_type *cons_u = + gcc_jit_context_new_union_type (comp.ctxt, + NULL, + "comp_cons_u", + sizeof (cons_u_fields) + / sizeof (*cons_u_fields), + cons_u_fields); + + comp.lisp_cons_u = + gcc_jit_context_new_field (comp.ctxt, + NULL, + cons_u, + "u"); + gcc_jit_struct_set_fields (comp.lisp_cons_s, + NULL, 1, &comp.lisp_cons_u); + +} + +/* opaque jmp_buf definition. */ static void define_jmp_buf (void) @@ -1159,7 +1268,7 @@ init_comp (int opt_level) comp.lisp_obj_as_num }; comp.lisp_obj_type = gcc_jit_context_new_union_type (comp.ctxt, NULL, - "LispObj", + "comp_Lisp_Object", sizeof (lisp_obj_fields) / sizeof (*lisp_obj_fields), lisp_obj_fields); @@ -1240,6 +1349,7 @@ init_comp (int opt_level) comp.func_hash = CALLN (Fmake_hash_table, QCtest, Qequal, QCweakness, Qt); + define_lisp_cons (); define_jmp_buf (); define_handler_struct (); define_thread_state_struct (); commit 1f26e751043c3c15a8c94a344428066e22e9e625 Author: Andrea Corallo Date: Sun Jun 23 19:17:22 2019 +0200 CASE_CALL_NARGS -> CASE_CALL_N diff --git a/src/comp.c b/src/comp.c index 154a1a9028..ca78d9317d 100644 --- a/src/comp.c +++ b/src/comp.c @@ -138,7 +138,7 @@ along with GNU Emacs. If not, see . */ /* Generate appropriate case and emit call to function. */ -#define CASE_CALL_NARGS(name, nargs) \ +#define CASE_CALL_N(name, nargs) \ CASE (B##name) \ EMIT_CALL_N (STR(F##name), nargs); \ break @@ -1643,8 +1643,8 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, } break; - CASE_CALL_NARGS (nth, 2); - CASE_CALL_NARGS (symbolp, 1); + CASE_CALL_N (nth, 2); + CASE_CALL_N (symbolp, 1); CASE (Bconsp) POP1; @@ -1657,14 +1657,14 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, PUSH_RVAL (res); break; - CASE_CALL_NARGS (stringp, 1); - CASE_CALL_NARGS (listp, 1); - CASE_CALL_NARGS (eq, 2); - CASE_CALL_NARGS (memq, 1); - CASE_CALL_NARGS (not, 1); - CASE_CALL_NARGS (car, 1); - CASE_CALL_NARGS (cdr, 1); - CASE_CALL_NARGS (cons, 2); + CASE_CALL_N (stringp, 1); + CASE_CALL_N (listp, 1); + CASE_CALL_N (eq, 2); + CASE_CALL_N (memq, 1); + CASE_CALL_N (not, 1); + CASE_CALL_N (car, 1); + CASE_CALL_N (cdr, 1); + CASE_CALL_N (cons, 2); CASE (BlistN) op = FETCH; @@ -1694,15 +1694,15 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, break; } - CASE_CALL_NARGS (length, 1); - CASE_CALL_NARGS (aref, 2); - CASE_CALL_NARGS (aset, 3); - CASE_CALL_NARGS (symbol_value, 1); - CASE_CALL_NARGS (symbol_function, 1); - CASE_CALL_NARGS (set, 2); - CASE_CALL_NARGS (fset, 2); - CASE_CALL_NARGS (get, 2); - CASE_CALL_NARGS (substring, 3); + CASE_CALL_N (length, 1); + CASE_CALL_N (aref, 2); + CASE_CALL_N (aset, 3); + CASE_CALL_N (symbol_value, 1); + CASE_CALL_N (symbol_function, 1); + CASE_CALL_N (set, 2); + CASE_CALL_N (fset, 2); + CASE_CALL_N (get, 2); + CASE_CALL_N (substring, 3); CASE (Bconcat2) EMIT_CALL_N_REF ("Fconcat", 2); @@ -1941,7 +1941,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, PUSH_RVAL (res); break; - CASE_CALL_NARGS (goto_char, 1); + CASE_CALL_N (goto_char, 1); CASE (Binsert) EMIT_CALL_N_REF ("Finsert", 1); @@ -1971,15 +1971,15 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, PUSH_RVAL (res); break; - CASE_CALL_NARGS (char_after, 1); - CASE_CALL_NARGS (following_char, 0); + CASE_CALL_N (char_after, 1); + CASE_CALL_N (following_char, 0); CASE (Bpreceding_char) res = emit_call ("Fprevious_char", comp.lisp_obj_type, 0, args); PUSH_RVAL (res); break; - CASE_CALL_NARGS (current_column, 0); + CASE_CALL_N (current_column, 0); CASE (Bindent_to) POP1; @@ -1988,12 +1988,12 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, PUSH_RVAL (res); break; - CASE_CALL_NARGS (eolp, 0); - CASE_CALL_NARGS (eobp, 0); - CASE_CALL_NARGS (bolp, 0); - CASE_CALL_NARGS (bobp, 0); - CASE_CALL_NARGS (current_buffer, 0); - CASE_CALL_NARGS (set_buffer, 1); + CASE_CALL_N (eolp, 0); + CASE_CALL_N (eobp, 0); + CASE_CALL_N (bolp, 0); + CASE_CALL_N (bobp, 0); + CASE_CALL_N (current_buffer, 0); + CASE_CALL_N (set_buffer, 1); CASE (Bsave_current_buffer) /* Obsolete since ??. */ goto save_current; @@ -2010,17 +2010,17 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, PUSH_RVAL (res); break; - CASE_CALL_NARGS (forward_char, 1); - CASE_CALL_NARGS (forward_word, 1); - CASE_CALL_NARGS (skip_chars_forward, 2); - CASE_CALL_NARGS (skip_chars_backward, 2); - CASE_CALL_NARGS (forward_line, 1); - CASE_CALL_NARGS (char_syntax, 1); - CASE_CALL_NARGS (buffer_substring, 2); - CASE_CALL_NARGS (delete_region, 2); - CASE_CALL_NARGS (narrow_to_region, 2); - CASE_CALL_NARGS (widen, 0); - CASE_CALL_NARGS (end_of_line, 1); + CASE_CALL_N (forward_char, 1); + CASE_CALL_N (forward_word, 1); + CASE_CALL_N (skip_chars_forward, 2); + CASE_CALL_N (skip_chars_backward, 2); + CASE_CALL_N (forward_line, 1); + CASE_CALL_N (char_syntax, 1); + CASE_CALL_N (buffer_substring, 2); + CASE_CALL_N (delete_region, 2); + CASE_CALL_N (narrow_to_region, 2); + CASE_CALL_N (widen, 0); + CASE_CALL_N (end_of_line, 1); CASE (Bconstant2) goto do_constant; @@ -2142,11 +2142,11 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, error ("Bunbind_all not supported"); break; - CASE_CALL_NARGS (set_marker, 3); - CASE_CALL_NARGS (match_beginning, 1); - CASE_CALL_NARGS (match_end, 1); - CASE_CALL_NARGS (upcase, 1); - CASE_CALL_NARGS (downcase, 1); + CASE_CALL_N (set_marker, 3); + CASE_CALL_N (match_beginning, 1); + CASE_CALL_N (match_end, 1); + CASE_CALL_N (upcase, 1); + CASE_CALL_N (downcase, 1); CASE (Bstringeqlsign) EMIT_CALL_N ("Fstring_equal", 2); @@ -2156,13 +2156,13 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, EMIT_CALL_N ("Fstring_lessp", 2); break; - CASE_CALL_NARGS (equal, 2); - CASE_CALL_NARGS (nthcdr, 2); - CASE_CALL_NARGS (elt, 2); - CASE_CALL_NARGS (member, 2); - CASE_CALL_NARGS (assq, 2); - CASE_CALL_NARGS (setcar, 2); - CASE_CALL_NARGS (setcdr, 2); + CASE_CALL_N (equal, 2); + CASE_CALL_N (nthcdr, 2); + CASE_CALL_N (elt, 2); + CASE_CALL_N (member, 2); + CASE_CALL_N (assq, 2); + CASE_CALL_N (setcar, 2); + CASE_CALL_N (setcdr, 2); CASE (Bcar_safe) EMIT_CALL_N ("CAR_SAFE", 1); @@ -2180,7 +2180,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, EMIT_CALL_N_REF ("Fquo", 2); break; - CASE_CALL_NARGS (rem, 2); + CASE_CALL_N (rem, 2); CASE (Bnumberp) POP1; commit 97b39deeeaa55c7cfed05cfb2ae57e2323a7c69c Author: Andrea Corallo Date: Sun Jun 23 19:16:10 2019 +0200 remove scratch call mechanism diff --git a/src/comp.c b/src/comp.c index 296f215cd2..154a1a9028 100644 --- a/src/comp.c +++ b/src/comp.c @@ -36,10 +36,6 @@ along with GNU Emacs. If not, see . */ #define MAX_FUN_NAME 256 -/* Max number of args we are able to handle while emitting function calls. */ - -#define MAX_ARGS 16 - #define DISASS_FILE_NAME "emacs-asm.s" #define CHECK_STACK \ @@ -147,13 +143,15 @@ along with GNU Emacs. If not, see . */ EMIT_CALL_N (STR(F##name), nargs); \ break -/* Emit calls to functions with prototype (ptrdiff_t nargs, Lisp_Object *args) - This is done aggregating args into the scratch_call_area. */ +/* + Emit calls to functions with prototype (ptrdiff_t nargs, Lisp_Object *args). + This is done by passing a reference to the first obj involved on the stack. +*/ -#define EMIT_SCRATCH_CALL_N(name, nargs) \ +#define EMIT_CALL_N_REF(name, nargs) \ do { \ - pop (nargs, &stack, args); \ - res = emit_scratch_callN (name, nargs, args); \ + DISCARD (nargs); \ + res = emit_call_n_ref (name, nargs, *stack); \ PUSH_RVAL (res); \ } while (0) @@ -214,7 +212,6 @@ typedef struct { gcc_jit_field *cast_union_as_i; gcc_jit_field *cast_union_as_b; gcc_jit_function *func; /* Current function being compiled */ - gcc_jit_rvalue *scratch; /* Will point to scratch_call_area */ gcc_jit_rvalue *most_positive_fixnum; gcc_jit_rvalue *most_negative_fixnum; gcc_jit_rvalue *one; @@ -228,8 +225,6 @@ typedef struct { static comp_t comp; -Lisp_Object scratch_call_area[MAX_ARGS]; - FILE *logfile = NULL; /* The result of one function compilation. */ @@ -722,60 +717,15 @@ emit_lisp_obj_from_ptr (basic_block_t *block, void *p) } static gcc_jit_rvalue * -emit_scratch_callN (const char *f_name, unsigned nargs, gcc_jit_rvalue **args) +emit_call_n_ref (const char *f_name, unsigned nargs, + gcc_jit_lvalue *base_arg) { - /* Here we set all the pointers into the scratch call area. */ - /* TODO: distinguish primitives for faster calling convention. */ - - /* - Lisp_Object *p; - p = scratch_call_area; - - p[0] = nargs; - p[1] = 0x...; - . - . - . - p[n] = 0x...; - */ - - gcc_jit_block_add_comment (comp.block->gcc_bb, - NULL, - format_string ("calling %s", f_name)); - - gcc_jit_lvalue *p = - gcc_jit_function_new_local(comp.func, - NULL, - gcc_jit_type_get_pointer (comp.lisp_obj_type), - "p"); - - gcc_jit_block_add_assignment(comp.block->gcc_bb, NULL, - p, - comp.scratch); - - for (int i = 0; i < nargs; i++) { - gcc_jit_rvalue *idx = - gcc_jit_context_new_rvalue_from_int ( - comp.ctxt, - gcc_jit_context_get_type(comp.ctxt, - GCC_JIT_TYPE_UNSIGNED_INT), - i); - gcc_jit_block_add_assignment ( - comp.block->gcc_bb, - NULL, - gcc_jit_context_new_array_access (comp.ctxt, - NULL, - gcc_jit_lvalue_as_rvalue(p), - idx), - args[i]); - } - - args[0] = gcc_jit_context_new_rvalue_from_int(comp.ctxt, + gcc_jit_rvalue *arguments[2] = + { gcc_jit_context_new_rvalue_from_int(comp.ctxt, comp.ptrdiff_type, - nargs); - args[1] = comp.scratch; - - return emit_call (f_name, comp.lisp_obj_type, 2, args); + nargs), + gcc_jit_lvalue_get_address (base_arg, NULL) }; + return emit_call (f_name, comp.lisp_obj_type, 2, arguments); } /* opaque jmp_buf definition */ @@ -1288,14 +1238,6 @@ init_comp (int opt_level) comp.ptrdiff_type = gcc_jit_context_get_type (comp.ctxt, ptrdiff_t_gcc); - comp.scratch = - gcc_jit_lvalue_get_address( - gcc_jit_context_new_global (comp.ctxt, NULL, - GCC_JIT_GLOBAL_IMPORTED, - comp.lisp_obj_type, - "scratch_call_area"), - NULL); - comp.func_hash = CALLN (Fmake_hash_table, QCtest, Qequal, QCweakness, Qt); define_jmp_buf (); @@ -1557,8 +1499,8 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, docall: { ptrdiff_t nargs = op + 1; - pop (nargs, &stack, args); - res = emit_scratch_callN ("Ffuncall", nargs, args); + DISCARD (nargs); + res = emit_call_n_ref ("Ffuncall", nargs, *stack); PUSH_RVAL (res); break; } @@ -1763,17 +1705,17 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, CASE_CALL_NARGS (substring, 3); CASE (Bconcat2) - EMIT_SCRATCH_CALL_N ("Fconcat", 2); + EMIT_CALL_N_REF ("Fconcat", 2); break; CASE (Bconcat3) - EMIT_SCRATCH_CALL_N ("Fconcat", 3); + EMIT_CALL_N_REF ("Fconcat", 3); break; CASE (Bconcat4) - EMIT_SCRATCH_CALL_N ("Fconcat", 4); + EMIT_CALL_N_REF ("Fconcat", 4); break; CASE (BconcatN) op = FETCH; - EMIT_SCRATCH_CALL_N ("Fconcat", op); + EMIT_CALL_N_REF ("Fconcat", op); break; CASE (Bsub1) @@ -1917,7 +1859,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, break; CASE (Bdiff) - EMIT_SCRATCH_CALL_N ("Fminus", 2); + EMIT_CALL_N_REF ("Fminus", 2); break; CASE (Bnegate) @@ -1966,7 +1908,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, basic_block_t bb_orig = *comp.block; comp.block->gcc_bb = negate_fcall_block; - EMIT_SCRATCH_CALL_N ("Fminus", 1); + EMIT_CALL_N_REF ("Fminus", 1); *comp.block = bb_orig; gcc_jit_block_end_with_jump (negate_inline_block, NULL, @@ -1976,16 +1918,16 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, } break; CASE (Bplus) - EMIT_SCRATCH_CALL_N ("Fplus", 2); + EMIT_CALL_N_REF ("Fplus", 2); break; CASE (Bmax) - EMIT_SCRATCH_CALL_N ("Fmax", 2); + EMIT_CALL_N_REF ("Fmax", 2); break; CASE (Bmin) - EMIT_SCRATCH_CALL_N ("Fmin", 2); + EMIT_CALL_N_REF ("Fmin", 2); break; CASE (Bmult) - EMIT_SCRATCH_CALL_N ("Ftimes", 2); + EMIT_CALL_N_REF ("Ftimes", 2); break; CASE (Bpoint) args[0] = @@ -2002,7 +1944,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, CASE_CALL_NARGS (goto_char, 1); CASE (Binsert) - EMIT_SCRATCH_CALL_N ("Finsert", 1); + EMIT_CALL_N_REF ("Finsert", 1); break; CASE (Bpoint_max) @@ -2231,11 +2173,11 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, break; CASE (Bnconc) - EMIT_SCRATCH_CALL_N ("Fnconc", 2); + EMIT_CALL_N_REF ("Fnconc", 2); break; CASE (Bquo) - EMIT_SCRATCH_CALL_N ("Fquo", 2); + EMIT_CALL_N_REF ("Fquo", 2); break; CASE_CALL_NARGS (rem, 2); @@ -2312,7 +2254,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, CASE (BinsertN) op = FETCH; - EMIT_SCRATCH_CALL_N ("Finsert", op); + EMIT_CALL_N_REF ("Finsert", op); break; CASE (Bstack_set) commit 5637eae4a4a1be757f5f203c7e08ec5cf1a69c03 Author: Andrea Corallo Date: Sun Jun 23 18:50:21 2019 +0200 locals to array diff --git a/src/comp.c b/src/comp.c index 1bbf1a0136..296f215cd2 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1367,11 +1367,24 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, comp.func = emit_func_declare (f_name, comp.lisp_obj_type, comp_res.max_args, NULL, GCC_JIT_FUNCTION_EXPORTED, false); + gcc_jit_lvalue *meta_stack_array = + gcc_jit_function_new_local ( + comp.func, + NULL, + gcc_jit_context_new_array_type (comp.ctxt, + NULL, + comp.lisp_obj_type, + stack_depth), + "local"); + for (int i = 0; i < stack_depth; ++i) - stack[i] = gcc_jit_function_new_local (comp.func, - NULL, - comp.lisp_obj_type, - format_string ("local_%d", i)); + stack[i] = gcc_jit_context_new_array_access ( + comp.ctxt, + NULL, + gcc_jit_lvalue_as_rvalue (meta_stack_array), + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.int_type, + i)); gcc_jit_block *prologue_bb = gcc_jit_function_new_block (comp.func, "prologue"); commit 3a64ec8021fee9694ead7b551d4ecbe7ef8ea869 Author: Andrea Corallo Date: Sun Jun 23 18:29:27 2019 +0200 bblock -> block diff --git a/src/comp.c b/src/comp.c index f2e7c2d102..1bbf1a0136 100644 --- a/src/comp.c +++ b/src/comp.c @@ -48,7 +48,7 @@ along with GNU Emacs. If not, see . */ #define PUSH_LVAL(obj) \ do { \ CHECK_STACK; \ - gcc_jit_block_add_assignment (comp.bblock->gcc_bb, \ + gcc_jit_block_add_assignment (comp.block->gcc_bb, \ NULL, \ *stack, \ gcc_jit_lvalue_as_rvalue(obj)); \ @@ -58,7 +58,7 @@ along with GNU Emacs. If not, see . */ #define PUSH_RVAL(obj) \ do { \ CHECK_STACK; \ - gcc_jit_block_add_assignment (comp.bblock->gcc_bb, \ + gcc_jit_block_add_assignment (comp.block->gcc_bb, \ NULL, \ *stack, \ (obj)); \ @@ -127,7 +127,7 @@ along with GNU Emacs. If not, see . */ #define CASE(op) \ case op : \ if (COMP_DEBUG) \ - gcc_jit_block_add_comment (comp.bblock->gcc_bb, \ + gcc_jit_block_add_comment (comp.block->gcc_bb, \ NULL, \ "Opcode " STR(op)); @@ -222,7 +222,7 @@ typedef struct { gcc_jit_rvalue *lisp_int0; gcc_jit_function *pseudovectorp; gcc_jit_function *bool_to_lisp_obj; - basic_block_t *bblock; /* Current basic block */ + basic_block_t *block; /* Current basic block */ Lisp_Object func_hash; /* f_name -> gcc_func */ } comp_t; @@ -412,12 +412,12 @@ INLINE static void emit_cond_jump (gcc_jit_rvalue *test, gcc_jit_block *then_target, gcc_jit_block *else_target) { - gcc_jit_block_end_with_conditional (comp.bblock->gcc_bb, + gcc_jit_block_end_with_conditional (comp.block->gcc_bb, NULL, test, then_target, else_target); - comp.bblock->terminated = true; + comp.block->terminated = true; } /* Close current basic block emitting a comparison between two rval. */ @@ -449,7 +449,7 @@ emit_cast (gcc_jit_type *new_type, gcc_jit_rvalue *obj) NULL, comp.cast_union_type, "union_cast"); - gcc_jit_block_add_assignment (comp.bblock->gcc_bb, + gcc_jit_block_add_assignment (comp.block->gcc_bb, NULL, gcc_jit_lvalue_access_field (tmp_u, NULL, @@ -693,7 +693,7 @@ emit_make_fixnum (gcc_jit_block *block, gcc_jit_rvalue *obj) /* Construct fill and return a lisp object form a raw pointer. */ /* TODO should we pass the bb? */ static gcc_jit_rvalue * -emit_lisp_obj_from_ptr (basic_block_t *bblock, void *p) +emit_lisp_obj_from_ptr (basic_block_t *block, void *p) { static unsigned i; @@ -709,12 +709,12 @@ emit_lisp_obj_from_ptr (basic_block_t *bblock, void *p) if (SYMBOLP (p)) gcc_jit_block_add_comment ( - bblock->gcc_bb, + block->gcc_bb, NULL, format_string ("Symbol %s", (char *) SDATA (SYMBOL_NAME (p)))); - gcc_jit_block_add_assignment (bblock->gcc_bb, + gcc_jit_block_add_assignment (block->gcc_bb, NULL, emit_lval_XLP (lisp_obj), void_ptr); @@ -739,7 +739,7 @@ emit_scratch_callN (const char *f_name, unsigned nargs, gcc_jit_rvalue **args) p[n] = 0x...; */ - gcc_jit_block_add_comment (comp.bblock->gcc_bb, + gcc_jit_block_add_comment (comp.block->gcc_bb, NULL, format_string ("calling %s", f_name)); @@ -749,7 +749,7 @@ emit_scratch_callN (const char *f_name, unsigned nargs, gcc_jit_rvalue **args) gcc_jit_type_get_pointer (comp.lisp_obj_type), "p"); - gcc_jit_block_add_assignment(comp.bblock->gcc_bb, NULL, + gcc_jit_block_add_assignment(comp.block->gcc_bb, NULL, p, comp.scratch); @@ -761,7 +761,7 @@ emit_scratch_callN (const char *f_name, unsigned nargs, gcc_jit_rvalue **args) GCC_JIT_TYPE_UNSIGNED_INT), i); gcc_jit_block_add_assignment ( - comp.bblock->gcc_bb, + comp.block->gcc_bb, NULL, gcc_jit_context_new_array_access (comp.ctxt, NULL, @@ -939,9 +939,9 @@ define_PSEUDOVECTORP (void) gcc_jit_function_new_block (comp.pseudovectorp, "call_pseudovector"); /* Set current context as needed */ - basic_block_t bblock = { .gcc_bb = initial_block, + basic_block_t block = { .gcc_bb = initial_block, .terminated = false }; - comp.bblock = &bblock; + comp.block = █ comp.func = comp.pseudovectorp; emit_cond_jump ( @@ -950,7 +950,7 @@ define_PSEUDOVECTORP (void) call_pseudovector_typep_b, ret_false_b); - comp.bblock->gcc_bb = ret_false_b; + comp.block->gcc_bb = ret_false_b; gcc_jit_block_end_with_return (ret_false_b, NULL, gcc_jit_context_new_rvalue_from_int( @@ -961,7 +961,7 @@ define_PSEUDOVECTORP (void) gcc_jit_rvalue *args[2] = { gcc_jit_param_as_rvalue (param[0]), gcc_jit_param_as_rvalue (param[1]) }; - comp.bblock->gcc_bb = call_pseudovector_typep_b; + comp.block->gcc_bb = call_pseudovector_typep_b; /* FIXME XUNTAG missing here. */ gcc_jit_block_end_with_return (call_pseudovector_typep_b, NULL, @@ -999,22 +999,22 @@ define_bool_to_lisp_obj (void) gcc_jit_function_new_block (comp.bool_to_lisp_obj, "ret_nil"); /* Set current context as needed */ - basic_block_t bblock = { .gcc_bb = initial_block, + basic_block_t block = { .gcc_bb = initial_block, .terminated = false }; - comp.bblock = &bblock; + comp.block = █ comp.func = comp.bool_to_lisp_obj; emit_cond_jump (gcc_jit_param_as_rvalue (param), ret_t_block, ret_nil_block); - bblock.gcc_bb = ret_t_block; + block.gcc_bb = ret_t_block; gcc_jit_block_end_with_return (ret_t_block, NULL, - emit_lisp_obj_from_ptr (&bblock, Qt)); - bblock.gcc_bb = ret_nil_block; + emit_lisp_obj_from_ptr (&block, Qt)); + block.gcc_bb = ret_nil_block; gcc_jit_block_end_with_return (ret_nil_block, NULL, - emit_lisp_obj_from_ptr (&bblock, Qnil)); + emit_lisp_obj_from_ptr (&block, Qnil)); } static int @@ -1027,7 +1027,7 @@ ucmp(const void *a, const void *b) /* Compute and initialize all basic blocks. */ static basic_block_t * -compute_bblocks (ptrdiff_t bytestr_length, unsigned char *bytestr_data) +compute_blocks (ptrdiff_t bytestr_length, unsigned char *bytestr_data) { ptrdiff_t pc = 0; unsigned op; @@ -1376,7 +1376,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, gcc_jit_block *prologue_bb = gcc_jit_function_new_block (comp.func, "prologue"); - basic_block_t *bb_map = compute_bblocks (bytestr_length, bytestr_data); + basic_block_t *bb_map = compute_blocks (bytestr_length, bytestr_data); for (ptrdiff_t i = 0; i < comp_res.max_args; ++i) PUSH_PARAM (gcc_jit_function_get_param (comp.func, i)); @@ -1384,7 +1384,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, gcc_jit_rvalue *nil = emit_lisp_obj_from_ptr (&bb_map[0], Qnil); - comp.bblock = NULL; + comp.block = NULL; while (pc < bytestr_length) { @@ -1392,13 +1392,13 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, /* If we are changing BB and the last was one wasn't terminated terminate it with a fall through. */ - if (comp.bblock && comp.bblock->gcc_bb != bb_map[pc].gcc_bb && - !comp.bblock->terminated) + if (comp.block && comp.block->gcc_bb != bb_map[pc].gcc_bb && + !comp.block->terminated) { - gcc_jit_block_end_with_jump (comp.bblock->gcc_bb, NULL, bb_map[pc].gcc_bb); - comp.bblock->terminated = true; + gcc_jit_block_end_with_jump (comp.block->gcc_bb, NULL, bb_map[pc].gcc_bb); + comp.block->terminated = true; } - comp.bblock = &bb_map[pc]; + comp.block = &bb_map[pc]; if (bb_map[pc].top) stack = bb_map[pc].top; op = FETCH; @@ -1449,7 +1449,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, op = FETCH; varref: { - args[0] = emit_lisp_obj_from_ptr (comp.bblock, vectorp[op]); + args[0] = emit_lisp_obj_from_ptr (comp.block, vectorp[op]); res = emit_call ("Fsymbol_value", comp.lisp_obj_type, 1, args); PUSH_RVAL (res); break; @@ -1480,7 +1480,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, { POP1; args[1] = args[0]; - args[0] = emit_lisp_obj_from_ptr (comp.bblock, vectorp[op]); + args[0] = emit_lisp_obj_from_ptr (comp.block, vectorp[op]); args[2] = nil; args[3] = gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.int_type, @@ -1513,7 +1513,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, op -= Bvarbind; varbind: { - args[0] = emit_lisp_obj_from_ptr (comp.bblock, vectorp[op]); + args[0] = emit_lisp_obj_from_ptr (comp.block, vectorp[op]); pop (1, &stack, &args[1]); res = emit_call ("specbind", comp.lisp_obj_type, 2, args); PUSH_RVAL (res); @@ -1591,7 +1591,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, comp.m_handlerlist); gcc_jit_block_add_assignment( - comp.bblock->gcc_bb, + comp.block->gcc_bb, NULL, m_handlerlist, gcc_jit_lvalue_as_rvalue ( @@ -1623,7 +1623,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, comp.int_type, type); gcc_jit_block_add_assignment ( - comp.bblock->gcc_bb, + comp.block->gcc_bb, NULL, c, emit_call ("push_handler", comp.handler_ptr_type, 2, args)); @@ -1657,14 +1657,14 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, gcc_jit_lvalue **stack_to_restore = stack; /* This emit the handler part. */ - basic_block_t bb_orig = *comp.bblock; - comp.bblock->gcc_bb = push_h_val_block; + basic_block_t bb_orig = *comp.block; + comp.block->gcc_bb = push_h_val_block; /* current_thread->m_handlerlist = c->next; */ gcc_jit_lvalue *m_handlerlist = gcc_jit_rvalue_dereference_field (comp.current_thread, NULL, comp.m_handlerlist); - gcc_jit_block_add_assignment(comp.bblock->gcc_bb, + gcc_jit_block_add_assignment(comp.block->gcc_bb, NULL, m_handlerlist, gcc_jit_lvalue_as_rvalue( @@ -1678,7 +1678,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, NULL, comp.handler_val_field)); bb_map[handler_pc].top = stack; - *comp.bblock = bb_orig; + *comp.block = bb_orig; gcc_jit_block_end_with_jump (push_h_val_block, NULL, bb_map[handler_pc].gcc_bb); @@ -1807,14 +1807,14 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, TOS, emit_make_fixnum (sub1_inline_block, sub1_inline_res)); - basic_block_t bb_orig = *comp.bblock; + basic_block_t bb_orig = *comp.block; - comp.bblock->gcc_bb = sub1_fcall_block; + comp.block->gcc_bb = sub1_fcall_block; POP1; res = emit_call ("Fsub1", comp.lisp_obj_type, 1, args); PUSH_RVAL (res); - *comp.bblock = bb_orig; + *comp.block = bb_orig; gcc_jit_block_end_with_jump (sub1_inline_block, NULL, bb_map[pc].gcc_bb); @@ -1867,14 +1867,14 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, TOS, emit_make_fixnum (add1_inline_block, add1_inline_res)); - basic_block_t bb_orig = *comp.bblock; + basic_block_t bb_orig = *comp.block; - comp.bblock->gcc_bb = add1_fcall_block; + comp.block->gcc_bb = add1_fcall_block; POP1; res = emit_call ("Fadd1", comp.lisp_obj_type, 1, args); PUSH_RVAL (res); - *comp.bblock = bb_orig; + *comp.block = bb_orig; gcc_jit_block_end_with_jump (add1_inline_block, NULL, bb_map[pc].gcc_bb); @@ -1950,11 +1950,11 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, TOS, emit_make_fixnum (negate_inline_block, negate_inline_res)); - basic_block_t bb_orig = *comp.bblock; + basic_block_t bb_orig = *comp.block; - comp.bblock->gcc_bb = negate_fcall_block; + comp.block->gcc_bb = negate_fcall_block; EMIT_SCRATCH_CALL_N ("Fminus", 1); - *comp.bblock = bb_orig; + *comp.block = bb_orig; gcc_jit_block_end_with_jump (negate_inline_block, NULL, bb_map[pc].gcc_bb); @@ -2049,7 +2049,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, break; CASE (Binteractive_p) /* Obsolete since 24.1. */ - PUSH_RVAL (emit_lisp_obj_from_ptr (comp.bblock, + PUSH_RVAL (emit_lisp_obj_from_ptr (comp.block, intern ("interactive-p"))); res = emit_call ("call0", comp.lisp_obj_type, 1, args); PUSH_RVAL (res); @@ -2073,10 +2073,10 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, CASE (Bgoto) op = FETCH2; - gcc_jit_block_end_with_jump (comp.bblock->gcc_bb, + gcc_jit_block_end_with_jump (comp.block->gcc_bb, NULL, bb_map[op].gcc_bb); - comp.bblock->terminated = true; + comp.block->terminated = true; bb_map[op].top = stack; break; @@ -2118,10 +2118,10 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, CASE (Breturn) POP1; - gcc_jit_block_end_with_return(comp.bblock->gcc_bb, + gcc_jit_block_end_with_return(comp.block->gcc_bb, NULL, args[0]); - comp.bblock->terminated = true; + comp.block->terminated = true; break; CASE (Bdiscard) @@ -2142,7 +2142,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, break; CASE (Bsave_restriction) - args[0] = emit_lisp_obj_from_ptr (comp.bblock, + args[0] = emit_lisp_obj_from_ptr (comp.block, save_restriction_restore); args[1] = emit_call ("save_restriction_save", comp.lisp_obj_type, @@ -2154,7 +2154,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, CASE (Bcatch) /* Obsolete since 24.4. */ POP2; args[2] = args[1]; - args[1] = emit_lisp_obj_from_ptr (comp.bblock, eval_sub); + args[1] = emit_lisp_obj_from_ptr (comp.block, eval_sub); emit_call ("internal_catch", comp.void_ptr_type, 3, args); break; @@ -2250,10 +2250,10 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, CASE (BRgoto) op = FETCH - 128; op += pc; - gcc_jit_block_end_with_jump (comp.bblock->gcc_bb, + gcc_jit_block_end_with_jump (comp.block->gcc_bb, NULL, bb_map[op].gcc_bb); - comp.bblock->terminated = true; + comp.block->terminated = true; bb_map[op].top = stack; break; @@ -2307,7 +2307,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, op = FETCH; POP1; if (op > 0) - gcc_jit_block_add_assignment (comp.bblock->gcc_bb, + gcc_jit_block_add_assignment (comp.block->gcc_bb, NULL, *(stack - op), args[0]); @@ -2316,7 +2316,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, CASE (Bstack_set2) op = FETCH2; POP1; - gcc_jit_block_add_assignment (comp.bblock->gcc_bb, + gcc_jit_block_add_assignment (comp.block->gcc_bb, NULL, *(stack - op), args[0]); @@ -2328,7 +2328,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, { op &= 0x7F; POP1; - gcc_jit_block_add_assignment (comp.bblock->gcc_bb, + gcc_jit_block_add_assignment (comp.block->gcc_bb, NULL, *(stack - op - 1), args[0]); @@ -2359,7 +2359,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, if (pc >= bytestr_length || bytestr_data[pc] != Bswitch) { gcc_jit_rvalue *c = - emit_lisp_obj_from_ptr (comp.bblock, vectorp[op]); + emit_lisp_obj_from_ptr (comp.block, vectorp[op]); PUSH_RVAL (c); break; } commit dbf05d0d22b1274898a9c545962abeef465d4119 Author: Andrea Corallo Date: Sun Jun 23 18:18:57 2019 +0200 add format_string diff --git a/src/comp.c b/src/comp.c index 0261cccc38..f2e7c2d102 100644 --- a/src/comp.c +++ b/src/comp.c @@ -243,6 +243,19 @@ void emacs_native_compile (const char *lisp_f_name, const char *c_f_name, Lisp_Object func, int opt_level, bool dump_asm); +static char * ATTRIBUTE_FORMAT_PRINTF (1, 2) +format_string (const char *format, ...) +{ + static char scratch_area[512]; + va_list va; + va_start (va, format); + int res = vsnprintf (scratch_area, sizeof (scratch_area), format, va); + if (res >= sizeof (scratch_area)) + error ("Truncating string"); + va_end (va); + return scratch_area; +} + static void bcall0 (Lisp_Object f) { @@ -683,30 +696,23 @@ static gcc_jit_rvalue * emit_lisp_obj_from_ptr (basic_block_t *bblock, void *p) { static unsigned i; - char scratch[256]; - - int res = snprintf (scratch, sizeof (scratch), - "lisp_obj_from_ptr_%u", i++); - if (res >= sizeof (scratch)) - error ("Internal error, truncating temporary variable"); - gcc_jit_lvalue *lisp_obj = gcc_jit_function_new_local (comp.func, - NULL, - comp.lisp_obj_type, - scratch); + gcc_jit_lvalue *lisp_obj = + gcc_jit_function_new_local (comp.func, + NULL, + comp.lisp_obj_type, + format_string ("lisp_obj_from_ptr_%u", i++)); gcc_jit_rvalue *void_ptr = gcc_jit_context_new_rvalue_from_ptr(comp.ctxt, comp.void_ptr_type, p); if (SYMBOLP (p)) - { - snprintf (scratch, sizeof (scratch), - "Symbol %s", (char *) SDATA (SYMBOL_NAME (p))); - gcc_jit_block_add_comment (bblock->gcc_bb, - NULL, - scratch); - } + gcc_jit_block_add_comment ( + bblock->gcc_bb, + NULL, + format_string ("Symbol %s", + (char *) SDATA (SYMBOL_NAME (p)))); gcc_jit_block_add_assignment (bblock->gcc_bb, NULL, @@ -718,8 +724,6 @@ emit_lisp_obj_from_ptr (basic_block_t *bblock, void *p) static gcc_jit_rvalue * emit_scratch_callN (const char *f_name, unsigned nargs, gcc_jit_rvalue **args) { - char tmp_str[256]; - /* Here we set all the pointers into the scratch call area. */ /* TODO: distinguish primitives for faster calling convention. */ @@ -735,11 +739,9 @@ emit_scratch_callN (const char *f_name, unsigned nargs, gcc_jit_rvalue **args) p[n] = 0x...; */ - snprintf (tmp_str, sizeof (tmp_str), "calling %s", f_name); - gcc_jit_block_add_comment (comp.bblock->gcc_bb, NULL, - tmp_str); + format_string ("calling %s", f_name)); gcc_jit_lvalue *p = gcc_jit_function_new_local(comp.func, @@ -1115,14 +1117,13 @@ compute_bblocks (ptrdiff_t bytestr_length, unsigned char *bytestr_data) } basic_block_t curr_bb; - char block_name[256]; for (int i = 0, pc = 0; pc < bytestr_length; pc++) { if (i < bb_n && pc == bb_start_pc[i]) { ++i; - snprintf (block_name, sizeof (block_name), "bb_%d", i); - curr_bb.gcc_bb = gcc_jit_function_new_block (comp.func, block_name); + curr_bb.gcc_bb = + gcc_jit_function_new_block (comp.func, format_string ("bb_%d", i)); curr_bb.top = NULL; curr_bb.terminated = false; } @@ -1331,7 +1332,6 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, ptrdiff_t pc = 0; gcc_jit_rvalue *args[4]; unsigned op; - char scratch_name[256]; unsigned pushhandler_n = 0; /* Meta-stack we use to flat the bytecode written for push and pop @@ -1368,13 +1368,10 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, NULL, GCC_JIT_FUNCTION_EXPORTED, false); for (int i = 0; i < stack_depth; ++i) - { - snprintf (scratch_name, sizeof (scratch_name), "local_%d", i); - stack[i] = gcc_jit_function_new_local (comp.func, - NULL, - comp.lisp_obj_type, - scratch_name); - } + stack[i] = gcc_jit_function_new_local (comp.func, + NULL, + comp.lisp_obj_type, + format_string ("local_%d", i)); gcc_jit_block *prologue_bb = gcc_jit_function_new_block (comp.func, "prologue"); @@ -1615,13 +1612,12 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, { /* struct handler *c = push_handler (POP, type); */ int handler_pc = FETCH2; - snprintf (scratch_name, sizeof (scratch_name), "c_%u", - pushhandler_n); gcc_jit_lvalue *c = gcc_jit_function_new_local (comp.func, NULL, comp.handler_ptr_type, - scratch_name); + format_string ("c_%u", + pushhandler_n)); POP1; args[1] = gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.int_type, @@ -1644,10 +1640,10 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, #else res = emit_call ("setjmp", comp.int_type, 1, args); #endif - snprintf (scratch_name, sizeof (scratch_name), "push_h_val_%u", - pushhandler_n); gcc_jit_block *push_h_val_block = - gcc_jit_function_new_block (comp.func, scratch_name); + gcc_jit_function_new_block (comp.func, + format_string ("push_h_val_%u", + pushhandler_n)); emit_cond_jump ( /* This negation is just to have a bool. */ gcc_jit_context_new_unary_op (comp.ctxt, commit d9e125793c36a06f0aca984473a911a92d1bbd7f Author: Andrea Corallo Date: Sun Jun 23 17:34:40 2019 +0200 postfix struct with _s diff --git a/src/comp.c b/src/comp.c index 31088f2332..0261cccc38 100644 --- a/src/comp.c +++ b/src/comp.c @@ -193,15 +193,15 @@ typedef struct { gcc_jit_field *lisp_obj_as_ptr; gcc_jit_field *lisp_obj_as_num; /* struct jmp_buf. */ - gcc_jit_struct *jmp_buf; + gcc_jit_struct *jmp_buf_s; /* struct handler. */ - gcc_jit_struct *handler; + gcc_jit_struct *handler_s; gcc_jit_field *handler_jmp_field; gcc_jit_field *handler_val_field; gcc_jit_field *handler_next_field; gcc_jit_type *handler_ptr_type; /* struct thread_state. */ - gcc_jit_struct *thread_state; + gcc_jit_struct *thread_state_s; gcc_jit_field *m_handlerlist; gcc_jit_type *thread_state_ptr_type; gcc_jit_rvalue *current_thread; @@ -790,7 +790,7 @@ define_jmp_buf (void) comp.char_type, sizeof (jmp_buf)), "stuff"); - comp.jmp_buf = + comp.jmp_buf_s = gcc_jit_context_new_struct_type (comp.ctxt, NULL, "comp_jmp_buf", @@ -802,14 +802,15 @@ define_jmp_buf (void) static void define_handler_struct (void) { - comp.handler = gcc_jit_context_new_opaque_struct (comp.ctxt, NULL, "comp_handler"); + comp.handler_s = + gcc_jit_context_new_opaque_struct (comp.ctxt, NULL, "comp_handler"); comp.handler_ptr_type = - gcc_jit_type_get_pointer (gcc_jit_struct_as_type (comp.handler)); + gcc_jit_type_get_pointer (gcc_jit_struct_as_type (comp.handler_s)); comp.handler_jmp_field = gcc_jit_context_new_field (comp.ctxt, NULL, gcc_jit_struct_as_type ( - comp.jmp_buf), + comp.jmp_buf_s), "jmp"); comp.handler_val_field = gcc_jit_context_new_field (comp.ctxt, NULL, @@ -851,7 +852,7 @@ define_handler_struct (void) - offsetof (struct handler, jmp) - sizeof (((struct handler *) 0)->jmp)), "pad2") }; - gcc_jit_struct_set_fields (comp.handler, + gcc_jit_struct_set_fields (comp.handler_s, NULL, sizeof (fields) / sizeof (*fields), fields); @@ -892,14 +893,14 @@ define_thread_state_struct (void) - sizeof (((struct thread_state *) 0)->m_handlerlist)), "pad1") }; - comp.thread_state = + comp.thread_state_s = gcc_jit_context_new_struct_type (comp.ctxt, NULL, "comp_thread_state", sizeof (fields) / sizeof (*fields), fields); comp.thread_state_ptr_type = - gcc_jit_type_get_pointer (gcc_jit_struct_as_type (comp.thread_state)); + gcc_jit_type_get_pointer (gcc_jit_struct_as_type (comp.thread_state_s)); } /* Declare a substitute for PSEUDOVECTORP as inline function. */ commit ee38ed1e7de2415b54cdfbd59a6f06d09b01779f Author: Andrea Corallo Date: Sun Jun 23 17:30:00 2019 +0200 add discard macro diff --git a/src/comp.c b/src/comp.c index 63318c5a58..31088f2332 100644 --- a/src/comp.c +++ b/src/comp.c @@ -79,6 +79,8 @@ along with GNU Emacs. If not, see . */ #define TOS (*(stack - 1)) +#define DISCARD(n) (stack -= (n)) + #define POP0 #define POP1 \ @@ -2104,7 +2106,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, nil, bb_map[op].gcc_bb, bb_map[pc].gcc_bb); bb_map[op].top = stack; - POP1; + DISCARD (1); break; CASE (Bgotoifnonnilelsepop) @@ -2114,7 +2116,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, nil, bb_map[op].gcc_bb, bb_map[pc].gcc_bb); bb_map[op].top = stack; - POP1; + DISCARD (1); break; CASE (Breturn) @@ -2126,7 +2128,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, break; CASE (Bdiscard) - POP1; + DISCARD (1); break; CASE (Bdup) @@ -2135,7 +2137,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, CASE (Bsave_excursion) res = emit_call ("record_unwind_protect_excursion", - comp.void_type, 0, args); + comp.void_type, 0, args); break; CASE (Bsave_window_excursion) /* Obsolete since 24.1. */ @@ -2284,7 +2286,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, nil, bb_map[op].gcc_bb, bb_map[pc].gcc_bb); bb_map[op].top = stack; - POP1; + DISCARD (1); break; CASE (BRgotoifnonnilelsepop) @@ -2295,7 +2297,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, nil, bb_map[op].gcc_bb, bb_map[pc].gcc_bb); bb_map[op].top = stack; - POP1; + DISCARD (1); break; CASE (BinsertN) @@ -2335,7 +2337,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, args[0]); } - stack -= op; + DISCARD (op); break; CASE (Bswitch) error ("Bswitch not supported"); commit 175d932b95ac918da6b9d0e4341a5e7715f04a39 Author: Andrea Corallo Date: Sun Jun 23 17:20:42 2019 +0200 set target stacks for safety diff --git a/src/comp.c b/src/comp.c index b2a16d84e1..63318c5a58 100644 --- a/src/comp.c +++ b/src/comp.c @@ -2078,6 +2078,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, NULL, bb_map[op].gcc_bb); comp.bblock->terminated = true; + bb_map[op].top = stack; break; CASE (Bgotoifnil) @@ -2085,6 +2086,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, POP1; emit_comparison_jump (GCC_JIT_COMPARISON_EQ, args[0], nil, bb_map[op].gcc_bb, bb_map[pc].gcc_bb); + bb_map[op].top = stack; break; CASE (Bgotoifnonnil) @@ -2092,6 +2094,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, POP1; emit_comparison_jump (GCC_JIT_COMPARISON_NE, args[0], nil, bb_map[op].gcc_bb, bb_map[pc].gcc_bb); + bb_map[op].top = stack; break; CASE (Bgotoifnilelsepop) @@ -2100,6 +2103,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, gcc_jit_lvalue_as_rvalue (TOS), nil, bb_map[op].gcc_bb, bb_map[pc].gcc_bb); + bb_map[op].top = stack; POP1; break; @@ -2109,6 +2113,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, gcc_jit_lvalue_as_rvalue (TOS), nil, bb_map[op].gcc_bb, bb_map[pc].gcc_bb); + bb_map[op].top = stack; POP1; break; @@ -2250,6 +2255,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, NULL, bb_map[op].gcc_bb); comp.bblock->terminated = true; + bb_map[op].top = stack; break; CASE (BRgotoifnil) @@ -2258,6 +2264,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, POP1; emit_comparison_jump (GCC_JIT_COMPARISON_EQ, args[0], nil, bb_map[op].gcc_bb, bb_map[pc].gcc_bb); + bb_map[op].top = stack; break; CASE (BRgotoifnonnil) @@ -2266,6 +2273,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, POP1; emit_comparison_jump (GCC_JIT_COMPARISON_NE, args[0], nil, bb_map[op].gcc_bb, bb_map[pc].gcc_bb); + bb_map[op].top = stack; break; CASE (BRgotoifnilelsepop) @@ -2275,6 +2283,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, gcc_jit_lvalue_as_rvalue (TOS), nil, bb_map[op].gcc_bb, bb_map[pc].gcc_bb); + bb_map[op].top = stack; POP1; break; @@ -2285,6 +2294,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, gcc_jit_lvalue_as_rvalue (TOS), nil, bb_map[op].gcc_bb, bb_map[pc].gcc_bb); + bb_map[op].top = stack; POP1; break; commit a328ce70ea6499239c47551f62b4428e556f52d3 Author: Andrea Corallo Date: Sun Jun 23 16:54:06 2019 +0200 fix struct thread_state definition diff --git a/src/comp.c b/src/comp.c index fe3fac606d..b2a16d84e1 100644 --- a/src/comp.c +++ b/src/comp.c @@ -887,13 +887,13 @@ define_thread_state_struct (void) sizeof (struct thread_state) - offsetof (struct thread_state, m_handlerlist) - - sizeof (struct handler *)), + - sizeof (((struct thread_state *) 0)->m_handlerlist)), "pad1") }; comp.thread_state = gcc_jit_context_new_struct_type (comp.ctxt, NULL, - "thread_state", + "comp_thread_state", sizeof (fields) / sizeof (*fields), fields); comp.thread_state_ptr_type = commit 0406c74b6083e0ddf08e386d935c07f6493e41d4 Author: Andrea Corallo Date: Sun Jun 23 16:41:04 2019 +0200 fix awful pad hack in define_handler_struct diff --git a/src/comp.c b/src/comp.c index aee7ca9946..fe3fac606d 100644 --- a/src/comp.c +++ b/src/comp.c @@ -818,56 +818,37 @@ define_handler_struct (void) comp.handler_ptr_type, "next"); gcc_jit_field *fields[] = - { gcc_jit_context_new_field (comp.ctxt, - NULL, - comp.int_type, - "type"), - gcc_jit_context_new_field (comp.ctxt, - NULL, - comp.lisp_obj_type, - "tag_or_ch"), - gcc_jit_context_new_field (comp.ctxt, - NULL, - comp.int_type, - "nonlocal_exit"), + { gcc_jit_context_new_field ( + comp.ctxt, + NULL, + gcc_jit_context_new_array_type (comp.ctxt, + NULL, + comp.char_type, + offsetof (struct handler, val)), + "pad0"), comp.handler_val_field, comp.handler_next_field, - gcc_jit_context_new_field (comp.ctxt, - NULL, - comp.handler_ptr_type, - "nextfree"), - gcc_jit_context_new_field (comp.ctxt, - NULL, - comp.lisp_obj_ptr_type, - "bytecode_top"), - gcc_jit_context_new_field (comp.ctxt, - NULL, - comp.int_type, - "bytecode_dest"), - gcc_jit_context_new_field (comp.ctxt, - NULL, - gcc_jit_context_new_array_type (comp.ctxt, - NULL, - comp.char_type, - 4), - "pad"), + gcc_jit_context_new_field ( + comp.ctxt, + NULL, + gcc_jit_context_new_array_type (comp.ctxt, + NULL, + comp.char_type, + offsetof (struct handler, jmp) + - offsetof (struct handler, next) + - sizeof (((struct handler *) 0)->next)), + "pad1"), comp.handler_jmp_field, - gcc_jit_context_new_field (comp.ctxt, - NULL, - comp.emacs_int_type, - "f_lisp_eval_depth"), - gcc_jit_context_new_field (comp.ctxt, - NULL, - comp.ptrdiff_type, - "pdlcount"), - gcc_jit_context_new_field (comp.ctxt, - NULL, - comp.int_type, - "poll_suppress_count"), - gcc_jit_context_new_field (comp.ctxt, - NULL, - comp.int_type, - "interrupt_input_blocked") }; + gcc_jit_context_new_field ( + comp.ctxt, + NULL, + gcc_jit_context_new_array_type (comp.ctxt, + NULL, + comp.char_type, + sizeof (struct handler) + - offsetof (struct handler, jmp) + - sizeof (((struct handler *) 0)->jmp)), + "pad2") }; gcc_jit_struct_set_fields (comp.handler, NULL, sizeof (fields) / sizeof (*fields), commit 3f96f72b59a627944040228984ec48cf0f74ecec Author: Andrea Corallo Date: Sun Jun 23 12:08:59 2019 +0200 add non locals tests diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 6a643df9d3..6a7370a880 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -345,6 +345,61 @@ (buffer-string)) "abcd"))) +(ert-deftest comp-tests-non-locals () + "Test non locals." + (defun comp-tests-err-arith-f () + (/ 1 0)) + (defun comp-tests-err-foo-f () + (error "foo")) + + (defun comp-tests-condition-case-0-f () + ;; Bpushhandler Bpophandler + (condition-case + err + (comp-tests-err-arith-f) + (arith-error (concat "arith-error " + (error-message-string err) + " catched")) + (error (concat "error " + (error-message-string err) + " catched")))) + + (defun comp-tests-condition-case-1-f () + ;; Bpushhandler Bpophandler + (condition-case + err + (comp-tests-err-foo-f) + (arith-error (concat "arith-error " + (error-message-string err) + " catched")) + (error (concat "error " + (error-message-string err) + " catched")))) + + (defun comp-tests-catch-f (f) + (catch 'foo + (funcall f))) + + (defun comp-tests-throw-f (x) + (throw 'foo x)) + + (byte-compile #'comp-tests-condition-case-0-f) + (native-compile #'comp-tests-condition-case-0-f) + (byte-compile #'comp-tests-condition-case-1-f) + (native-compile #'comp-tests-condition-case-1-f) + (byte-compile #'comp-tests-catch-f) + (native-compile #'comp-tests-catch-f) + (byte-compile #'comp-tests-throw-f) + (native-compile #'comp-tests-throw-f) + + (should (string= (comp-tests-condition-case-0-f) + "arith-error Arithmetic error catched")) + (should (string= (comp-tests-condition-case-1-f) + "error foo catched")) + (should (= (comp-tests-catch-f (lambda () (throw 'foo 3))) 3)) + (should (= (catch 'foo + (comp-tests-throw-f 3))))) + (ert-deftest comp-tests-gc () "Try to do some longer computation to let the gc kick in." (dotimes (_ 100000) commit 39390edcf95f3fe21dbb68e0e35f1d8b5b93588e Author: Andrea Corallo Date: Sun Jun 23 11:44:30 2019 +0200 jmp_buf as struct + offset workaround diff --git a/src/comp.c b/src/comp.c index 61809a0122..aee7ca9946 100644 --- a/src/comp.c +++ b/src/comp.c @@ -186,11 +186,12 @@ typedef struct { gcc_jit_type *emacs_int_type; gcc_jit_type *void_ptr_type; gcc_jit_type *ptrdiff_type; - gcc_jit_type *jmp_buf_type; gcc_jit_type *lisp_obj_type; gcc_jit_type *lisp_obj_ptr_type; gcc_jit_field *lisp_obj_as_ptr; gcc_jit_field *lisp_obj_as_num; + /* struct jmp_buf. */ + gcc_jit_struct *jmp_buf; /* struct handler. */ gcc_jit_struct *handler; gcc_jit_field *handler_jmp_field; @@ -773,18 +774,40 @@ emit_scratch_callN (const char *f_name, unsigned nargs, gcc_jit_rvalue **args) return emit_call (f_name, comp.lisp_obj_type, 2, args); } +/* opaque jmp_buf definition */ + +static void +define_jmp_buf (void) +{ + gcc_jit_field *field = + gcc_jit_context_new_field ( + comp.ctxt, + NULL, + gcc_jit_context_new_array_type (comp.ctxt, + NULL, + comp.char_type, + sizeof (jmp_buf)), + "stuff"); + comp.jmp_buf = + gcc_jit_context_new_struct_type (comp.ctxt, + NULL, + "comp_jmp_buf", + 1, &field); +} + /* struct handler definition */ static void define_handler_struct (void) { - comp.handler = gcc_jit_context_new_opaque_struct (comp.ctxt, NULL, "handler"); + comp.handler = gcc_jit_context_new_opaque_struct (comp.ctxt, NULL, "comp_handler"); comp.handler_ptr_type = gcc_jit_type_get_pointer (gcc_jit_struct_as_type (comp.handler)); comp.handler_jmp_field = gcc_jit_context_new_field (comp.ctxt, NULL, - comp.jmp_buf_type, + gcc_jit_struct_as_type ( + comp.jmp_buf), "jmp"); comp.handler_val_field = gcc_jit_context_new_field (comp.ctxt, NULL, @@ -821,6 +844,13 @@ define_handler_struct (void) NULL, comp.int_type, "bytecode_dest"), + gcc_jit_context_new_field (comp.ctxt, + NULL, + gcc_jit_context_new_array_type (comp.ctxt, + NULL, + comp.char_type, + 4), + "pad"), comp.handler_jmp_field, gcc_jit_context_new_field (comp.ctxt, NULL, @@ -1273,11 +1303,6 @@ init_comp (int opt_level) comp.ptrdiff_type = gcc_jit_context_get_type (comp.ctxt, ptrdiff_t_gcc); - /* Opaque definition for jmp_buf. */ - comp.jmp_buf_type = gcc_jit_context_new_array_type (comp.ctxt, - NULL, - comp.char_type, - sizeof (jmp_buf)); comp.scratch = gcc_jit_lvalue_get_address( gcc_jit_context_new_global (comp.ctxt, NULL, @@ -1288,6 +1313,7 @@ init_comp (int opt_level) comp.func_hash = CALLN (Fmake_hash_table, QCtest, Qequal, QCweakness, Qt); + define_jmp_buf (); define_handler_struct (); define_thread_state_struct (); comp.current_thread = commit cc78d4c34e5b5701c893bac88e86af6791e204e2 Author: Andrea Corallo Date: Sun Jun 23 10:18:35 2019 +0200 fix pushhandler diff --git a/src/comp.c b/src/comp.c index e0688b626a..61809a0122 100644 --- a/src/comp.c +++ b/src/comp.c @@ -167,6 +167,8 @@ along with GNU Emacs. If not, see . */ typedef struct { gcc_jit_block *gcc_bb; + /* When non zero indicates a stack pointer restart. */ + gcc_jit_lvalue **top; bool terminated; } basic_block_t; @@ -1060,6 +1062,8 @@ compute_bblocks (ptrdiff_t bytestr_length, unsigned char *bytestr_data) case Bgotoifnonnil: case Bgotoifnilelsepop: case Bgotoifnonnilelsepop: + case Bpushcatch: + case Bpushconditioncase: op = FETCH2; bb_start_pc[bb_n++] = op; new_bb = true; @@ -1075,8 +1079,6 @@ compute_bblocks (ptrdiff_t bytestr_length, unsigned char *bytestr_data) new_bb = true; break; /* Other ops changing bb */ - case Bpushcatch: - case Bpushconditioncase: case Bsub1: case Badd1: case Bnegate: @@ -1107,6 +1109,7 @@ compute_bblocks (ptrdiff_t bytestr_length, unsigned char *bytestr_data) ++i; snprintf (block_name, sizeof (block_name), "bb_%d", i); curr_bb.gcc_bb = gcc_jit_function_new_block (comp.func, block_name); + curr_bb.top = NULL; curr_bb.terminated = false; } bb_map[pc] = curr_bb; @@ -1389,6 +1392,8 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, comp.bblock->terminated = true; } comp.bblock = &bb_map[pc]; + if (bb_map[pc].top) + stack = bb_map[pc].top; op = FETCH; switch (op) @@ -1591,11 +1596,11 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, } CASE (Bpushconditioncase) /* New in 24.4. */ - type = CATCHER; + type = CONDITION_CASE; goto pushhandler; CASE (Bpushcatch) /* New in 24.4. */ - type = CONDITION_CASE;; + type = CATCHER; pushhandler: { /* struct handler *c = push_handler (POP, type); */ @@ -1643,6 +1648,9 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, bb_map[pc].gcc_bb, push_h_val_block); + gcc_jit_lvalue **stack_to_restore = stack; + /* This emit the handler part. */ + basic_block_t bb_orig = *comp.bblock; comp.bblock->gcc_bb = push_h_val_block; /* current_thread->m_handlerlist = c->next; */ @@ -1663,10 +1671,13 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, gcc_jit_rvalue_dereference_field (gcc_jit_lvalue_as_rvalue (c), NULL, comp.handler_val_field)); + bb_map[handler_pc].top = stack; *comp.bblock = bb_orig; gcc_jit_block_end_with_jump (push_h_val_block, NULL, bb_map[handler_pc].gcc_bb); + + stack = stack_to_restore; ++pushhandler_n; } break; commit 1d46302e725fabf7ccb2cfbe76c2b175039ac0f0 Author: Andrea Corallo Date: Sat Jun 22 18:04:16 2019 +0200 dump all ops as comments diff --git a/src/comp.c b/src/comp.c index 8563ff0b8f..e0688b626a 100644 --- a/src/comp.c +++ b/src/comp.c @@ -122,6 +122,13 @@ along with GNU Emacs. If not, see . */ /* With most of the ops we need to do the same stuff so this macros are meant to save some typing. */ +#define CASE(op) \ + case op : \ + if (COMP_DEBUG) \ + gcc_jit_block_add_comment (comp.bblock->gcc_bb, \ + NULL, \ + "Opcode " STR(op)); + /* Pop from the meta-stack, emit the call and push the result */ #define EMIT_CALL_N(name, nargs) \ @@ -134,7 +141,7 @@ along with GNU Emacs. If not, see . */ /* Generate appropriate case and emit call to function. */ #define CASE_CALL_NARGS(name, nargs) \ - case B##name: \ + CASE (B##name) \ EMIT_CALL_N (STR(F##name), nargs); \ break @@ -1386,36 +1393,47 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, switch (op) { - case Bstack_ref1: - case Bstack_ref2: - case Bstack_ref3: - case Bstack_ref4: - case Bstack_ref5: + CASE (Bstack_ref1) + goto stack_ref; + CASE (Bstack_ref2) + goto stack_ref; + CASE (Bstack_ref3) + goto stack_ref; + CASE (Bstack_ref4) + goto stack_ref; + CASE (Bstack_ref5) + stack_ref: PUSH_LVAL (stack_base[(stack - stack_base) - (op - Bstack_ref) - 1]); break; - case Bstack_ref6: + CASE (Bstack_ref6) PUSH_LVAL (stack_base[(stack - stack_base) - FETCH - 1]); break; - case Bstack_ref7: + CASE (Bstack_ref7) PUSH_LVAL (stack_base[(stack - stack_base) - FETCH2 - 1]); break; - case Bvarref7: + CASE (Bvarref7) op = FETCH2; goto varref; - case Bvarref: - case Bvarref1: - case Bvarref2: - case Bvarref3: - case Bvarref4: - case Bvarref5: + CASE (Bvarref) + goto varref_count; + CASE (Bvarref1) + goto varref_count; + CASE (Bvarref2) + goto varref_count; + CASE (Bvarref3) + goto varref_count; + CASE (Bvarref4) + goto varref_count; + CASE (Bvarref5) + varref_count: op -= Bvarref; goto varref; - case Bvarref6: + CASE (Bvarref6) op = FETCH; varref: { @@ -1425,20 +1443,26 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, break; } - case Bvarset: - case Bvarset1: - case Bvarset2: - case Bvarset3: - case Bvarset4: - case Bvarset5: + CASE (Bvarset) + goto varset_count; + CASE (Bvarset1) + goto varset_count; + CASE (Bvarset2) + goto varset_count; + CASE (Bvarset3) + goto varset_count; + CASE (Bvarset4) + goto varset_count; + CASE (Bvarset5) + varset_count: op -= Bvarset; goto varset; - case Bvarset7: + CASE (Bvarset7) op = FETCH2; goto varset; - case Bvarset6: + CASE (Bvarset6) op = FETCH; varset: { @@ -1454,20 +1478,26 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, } break; - case Bvarbind6: + CASE (Bvarbind6) op = FETCH; goto varbind; - case Bvarbind7: + CASE (Bvarbind7) op = FETCH2; goto varbind; - case Bvarbind: - case Bvarbind1: - case Bvarbind2: - case Bvarbind3: - case Bvarbind4: - case Bvarbind5: + CASE (Bvarbind) + goto varbind_count; + CASE (Bvarbind1) + goto varbind_count; + CASE (Bvarbind2) + goto varbind_count; + CASE (Bvarbind3) + goto varbind_count; + CASE (Bvarbind4) + goto varbind_count; + CASE (Bvarbind5) + varbind_count: op -= Bvarbind; varbind: { @@ -1478,20 +1508,26 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, break; } - case Bcall6: + CASE (Bcall6) op = FETCH; goto docall; - case Bcall7: + CASE (Bcall7) op = FETCH2; goto docall; - case Bcall: - case Bcall1: - case Bcall2: - case Bcall3: - case Bcall4: - case Bcall5: + CASE (Bcall) + goto docall_count; + CASE (Bcall1) + goto docall_count; + CASE (Bcall2) + goto docall_count; + CASE (Bcall3) + goto docall_count; + CASE (Bcall4) + goto docall_count; + CASE (Bcall5) + docall_count: op -= Bcall; docall: { @@ -1502,20 +1538,26 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, break; } - case Bunbind6: + CASE (Bunbind6) op = FETCH; goto dounbind; - case Bunbind7: + CASE (Bunbind7) op = FETCH2; goto dounbind; - case Bunbind: - case Bunbind1: - case Bunbind2: - case Bunbind3: - case Bunbind4: - case Bunbind5: + CASE (Bunbind) + goto dounbind_count; + CASE (Bunbind1) + goto dounbind_count; + CASE (Bunbind2) + goto dounbind_count; + CASE (Bunbind3) + goto dounbind_count; + CASE (Bunbind4) + goto dounbind_count; + CASE (Bunbind5) + dounbind_count: op -= Bunbind; dounbind: { @@ -1527,7 +1569,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, } break; - case Bpophandler: + CASE (Bpophandler) { /* current_thread->m_handlerlist = current_thread->m_handlerlist->next; */ @@ -1548,11 +1590,11 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, break; } - case Bpushconditioncase: /* New in 24.4. */ + CASE (Bpushconditioncase) /* New in 24.4. */ type = CATCHER; goto pushhandler; - case Bpushcatch: /* New in 24.4. */ + CASE (Bpushcatch) /* New in 24.4. */ type = CONDITION_CASE;; pushhandler: { @@ -1632,7 +1674,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, CASE_CALL_NARGS (nth, 2); CASE_CALL_NARGS (symbolp, 1); - case Bconsp: + CASE (Bconsp) POP1; res = emit_cast (comp.bool_type, emit_CONSP (args[0])); @@ -1652,14 +1694,18 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, CASE_CALL_NARGS (cdr, 1); CASE_CALL_NARGS (cons, 2); - case BlistN: + CASE (BlistN) op = FETCH; goto make_list; - case Blist1: - case Blist2: - case Blist3: - case Blist4: + CASE (Blist1) + goto make_list_count; + CASE (Blist2) + goto make_list_count; + CASE (Blist3) + goto make_list_count; + CASE (Blist4) + make_list_count: op = op - Blist1; make_list: { @@ -1686,21 +1732,21 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, CASE_CALL_NARGS (get, 2); CASE_CALL_NARGS (substring, 3); - case Bconcat2: + CASE (Bconcat2) EMIT_SCRATCH_CALL_N ("Fconcat", 2); break; - case Bconcat3: + CASE (Bconcat3) EMIT_SCRATCH_CALL_N ("Fconcat", 3); break; - case Bconcat4: + CASE (Bconcat4) EMIT_SCRATCH_CALL_N ("Fconcat", 4); break; - case BconcatN: + CASE (BconcatN) op = FETCH; EMIT_SCRATCH_CALL_N ("Fconcat", op); break; - case Bsub1: + CASE (Bsub1) { /* (FIXNUMP (TOP) && XFIXNUM (TOP) != MOST_NEGATIVE_FIXNUM @@ -1760,7 +1806,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, } break; - case Badd1: + CASE (Badd1) { /* (FIXNUMP (TOP) && XFIXNUM (TOP) != MOST_POSITIVE_FIXNUM @@ -1820,31 +1866,31 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, } break; - case Beqlsign: + CASE (Beqlsign) EMIT_ARITHCOMPARE (ARITH_EQUAL); break; - case Bgtr: + CASE (Bgtr) EMIT_ARITHCOMPARE (ARITH_GRTR); break; - case Blss: + CASE (Blss) EMIT_ARITHCOMPARE (ARITH_LESS); break; - case Bleq: + CASE (Bleq) EMIT_ARITHCOMPARE (ARITH_LESS_OR_EQUAL); break; - case Bgeq: + CASE (Bgeq) EMIT_ARITHCOMPARE (ARITH_GRTR_OR_EQUAL); break; - case Bdiff: + CASE (Bdiff) EMIT_SCRATCH_CALL_N ("Fminus", 2); break; - case Bnegate: + CASE (Bnegate) { /* (FIXNUMP (TOP) && XFIXNUM (TOP) != MOST_NEGATIVE_FIXNUM @@ -1899,19 +1945,19 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, bb_map[pc].gcc_bb); } break; - case Bplus: + CASE (Bplus) EMIT_SCRATCH_CALL_N ("Fplus", 2); break; - case Bmax: + CASE (Bmax) EMIT_SCRATCH_CALL_N ("Fmax", 2); break; - case Bmin: + CASE (Bmin) EMIT_SCRATCH_CALL_N ("Fmin", 2); break; - case Bmult: + CASE (Bmult) EMIT_SCRATCH_CALL_N ("Ftimes", 2); break; - case Bpoint: + CASE (Bpoint) args[0] = gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.ptrdiff_type, @@ -1925,11 +1971,11 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, CASE_CALL_NARGS (goto_char, 1); - case Binsert: + CASE (Binsert) EMIT_SCRATCH_CALL_N ("Finsert", 1); break; - case Bpoint_max: + CASE (Bpoint_max) args[0] = gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.ptrdiff_type, @@ -1941,7 +1987,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, PUSH_RVAL (res); break; - case Bpoint_min: + CASE (Bpoint_min) args[0] = gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.ptrdiff_type, @@ -1956,14 +2002,14 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, CASE_CALL_NARGS (char_after, 1); CASE_CALL_NARGS (following_char, 0); - case Bpreceding_char: + CASE (Bpreceding_char) res = emit_call ("Fprevious_char", comp.lisp_obj_type, 0, args); PUSH_RVAL (res); break; CASE_CALL_NARGS (current_column, 0); - case Bindent_to: + CASE (Bindent_to) POP1; args[1] = nil; res = emit_call ("Findent_to", comp.lisp_obj_type, 2, args); @@ -1977,13 +2023,15 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, CASE_CALL_NARGS (current_buffer, 0); CASE_CALL_NARGS (set_buffer, 1); - case Bsave_current_buffer: /* Obsolete since ??. */ - case Bsave_current_buffer_1: + CASE (Bsave_current_buffer) /* Obsolete since ??. */ + goto save_current; + CASE (Bsave_current_buffer_1) + save_current: emit_call ("record_unwind_current_buffer", comp.void_type, 0, NULL); break; - case Binteractive_p: /* Obsolete since 24.1. */ + CASE (Binteractive_p) /* Obsolete since 24.1. */ PUSH_RVAL (emit_lisp_obj_from_ptr (comp.bblock, intern ("interactive-p"))); res = emit_call ("call0", comp.lisp_obj_type, 1, args); @@ -2002,11 +2050,11 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, CASE_CALL_NARGS (widen, 0); CASE_CALL_NARGS (end_of_line, 1); - case Bconstant2: + CASE (Bconstant2) goto do_constant; break; - case Bgoto: + CASE (Bgoto) op = FETCH2; gcc_jit_block_end_with_jump (comp.bblock->gcc_bb, NULL, @@ -2014,21 +2062,21 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, comp.bblock->terminated = true; break; - case Bgotoifnil: + CASE (Bgotoifnil) op = FETCH2; POP1; emit_comparison_jump (GCC_JIT_COMPARISON_EQ, args[0], nil, bb_map[op].gcc_bb, bb_map[pc].gcc_bb); break; - case Bgotoifnonnil: + CASE (Bgotoifnonnil) op = FETCH2; POP1; emit_comparison_jump (GCC_JIT_COMPARISON_NE, args[0], nil, bb_map[op].gcc_bb, bb_map[pc].gcc_bb); break; - case Bgotoifnilelsepop: + CASE (Bgotoifnilelsepop) op = FETCH2; emit_comparison_jump (GCC_JIT_COMPARISON_EQ, gcc_jit_lvalue_as_rvalue (TOS), @@ -2037,7 +2085,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, POP1; break; - case Bgotoifnonnilelsepop: + CASE (Bgotoifnonnilelsepop) op = FETCH2; emit_comparison_jump (GCC_JIT_COMPARISON_NE, gcc_jit_lvalue_as_rvalue (TOS), @@ -2046,7 +2094,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, POP1; break; - case Breturn: + CASE (Breturn) POP1; gcc_jit_block_end_with_return(comp.bblock->gcc_bb, NULL, @@ -2054,24 +2102,24 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, comp.bblock->terminated = true; break; - case Bdiscard: + CASE (Bdiscard) POP1; break; - case Bdup: + CASE (Bdup) PUSH_LVAL (TOS); break; - case Bsave_excursion: + CASE (Bsave_excursion) res = emit_call ("record_unwind_protect_excursion", comp.void_type, 0, args); break; - case Bsave_window_excursion: /* Obsolete since 24.1. */ + CASE (Bsave_window_excursion) /* Obsolete since 24.1. */ EMIT_CALL_N ("helper_save_window_excursion", 1); break; - case Bsave_restriction: + CASE (Bsave_restriction) args[0] = emit_lisp_obj_from_ptr (comp.bblock, save_restriction_restore); args[1] = emit_call ("save_restriction_save", @@ -2081,29 +2129,29 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, emit_call ("record_unwind_protect", comp.void_ptr_type, 2, args); break; - case Bcatch: /* Obsolete since 24.4. */ + CASE (Bcatch) /* Obsolete since 24.4. */ POP2; args[2] = args[1]; args[1] = emit_lisp_obj_from_ptr (comp.bblock, eval_sub); emit_call ("internal_catch", comp.void_ptr_type, 3, args); break; - case Bunwind_protect: /* FIXME: avoid closure for lexbind. */ + CASE (Bunwind_protect) /* FIXME: avoid closure for lexbind. */ POP1; emit_call ("helper_unwind_protect", comp.void_type, 1, args); break; - case Bcondition_case: /* Obsolete since 24.4. */ + CASE (Bcondition_case) /* Obsolete since 24.4. */ POP3; emit_call ("internal_lisp_condition_case", comp.lisp_obj_type, 3, args); break; - case Btemp_output_buffer_setup: /* Obsolete since 24.1. */ + CASE (Btemp_output_buffer_setup) /* Obsolete since 24.1. */ EMIT_CALL_N ("helper_temp_output_buffer_setup", 1); break; - case Btemp_output_buffer_show: /* Obsolete since 24.1. */ + CASE (Btemp_output_buffer_show) /* Obsolete since 24.1. */ POP2; emit_call ("temp_output_buffer_show", comp.void_type, 1, &args[1]); @@ -2111,7 +2159,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, emit_call ("helper_unbind_n", comp.lisp_obj_type, 1, args); break; - case Bunbind_all: /* Obsolete. Never used. */ + CASE (Bunbind_all) /* Obsolete. Never used. */ /* To unbind back to the beginning of this frame. Not used yet, but will be needed for tail-recursion elimination. */ error ("Bunbind_all not supported"); @@ -2123,11 +2171,11 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, CASE_CALL_NARGS (upcase, 1); CASE_CALL_NARGS (downcase, 1); - case Bstringeqlsign: + CASE (Bstringeqlsign) EMIT_CALL_N ("Fstring_equal", 2); break; - case Bstringlss: + CASE (Bstringlss) EMIT_CALL_N ("Fstring_lessp", 2); break; @@ -2139,25 +2187,25 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, CASE_CALL_NARGS (setcar, 2); CASE_CALL_NARGS (setcdr, 2); - case Bcar_safe: + CASE (Bcar_safe) EMIT_CALL_N ("CAR_SAFE", 1); break; - case Bcdr_safe: + CASE (Bcdr_safe) EMIT_CALL_N ("CDR_SAFE", 1); break; - case Bnconc: + CASE (Bnconc) EMIT_SCRATCH_CALL_N ("Fnconc", 2); break; - case Bquo: + CASE (Bquo) EMIT_SCRATCH_CALL_N ("Fquo", 2); break; CASE_CALL_NARGS (rem, 2); - case Bnumberp: + CASE (Bnumberp) POP1; res = emit_NUMBERP (args[0]); res = gcc_jit_context_new_call (comp.ctxt, @@ -2167,7 +2215,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, PUSH_RVAL (res); break; - case Bintegerp: + CASE (Bintegerp) POP1; res = emit_INTEGERP(args[0]); res = gcc_jit_context_new_call (comp.ctxt, @@ -2177,7 +2225,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, PUSH_RVAL (res); break; - case BRgoto: + CASE (BRgoto) op = FETCH - 128; op += pc; gcc_jit_block_end_with_jump (comp.bblock->gcc_bb, @@ -2186,7 +2234,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, comp.bblock->terminated = true; break; - case BRgotoifnil: + CASE (BRgotoifnil) op = FETCH - 128; op += pc; POP1; @@ -2194,7 +2242,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, bb_map[op].gcc_bb, bb_map[pc].gcc_bb); break; - case BRgotoifnonnil: + CASE (BRgotoifnonnil) op = FETCH - 128; op += pc; POP1; @@ -2202,7 +2250,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, bb_map[op].gcc_bb, bb_map[pc].gcc_bb); break; - case BRgotoifnilelsepop: + CASE (BRgotoifnilelsepop) op = FETCH - 128; op += pc; emit_comparison_jump (GCC_JIT_COMPARISON_EQ, @@ -2212,7 +2260,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, POP1; break; - case BRgotoifnonnilelsepop: + CASE (BRgotoifnonnilelsepop) op = FETCH - 128; op += pc; emit_comparison_jump (GCC_JIT_COMPARISON_NE, @@ -2222,12 +2270,12 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, POP1; break; - case BinsertN: + CASE (BinsertN) op = FETCH; EMIT_SCRATCH_CALL_N ("Finsert", op); break; - case Bstack_set: + CASE (Bstack_set) /* stack-set-0 = discard; stack-set-1 = discard-1-preserve-tos. */ op = FETCH; POP1; @@ -2238,7 +2286,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, args[0]); break; - case Bstack_set2: + CASE (Bstack_set2) op = FETCH2; POP1; gcc_jit_block_add_assignment (comp.bblock->gcc_bb, @@ -2247,7 +2295,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, args[0]); break; - case BdiscardN: + CASE (BdiscardN) op = FETCH; if (op & 0x80) { @@ -2261,7 +2309,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, stack -= op; break; - case Bswitch: + CASE (Bswitch) error ("Bswitch not supported"); /* The cases of Bswitch that we handle (which in theory is all of them) are done in Bconstant, below. This is done @@ -2272,7 +2320,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, break; default: - case Bconstant: + CASE (Bconstant) { if (op < Bconstant || op > Bconstant + vector_size) goto fail; commit 11ca831f996e1a0a732f811de75008b714f3836a Author: Andrea Corallo Date: Sat Jun 22 17:36:18 2019 +0200 pushhandler diff --git a/src/comp.c b/src/comp.c index 74102c5536..8563ff0b8f 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1311,6 +1311,8 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, ptrdiff_t pc = 0; gcc_jit_rvalue *args[4]; unsigned op; + char scratch_name[256]; + unsigned pushhandler_n = 0; /* Meta-stack we use to flat the bytecode written for push and pop Emacs VM.*/ @@ -1345,14 +1347,13 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, comp.func = emit_func_declare (f_name, comp.lisp_obj_type, comp_res.max_args, NULL, GCC_JIT_FUNCTION_EXPORTED, false); - char local_name[256]; for (int i = 0; i < stack_depth; ++i) { - snprintf (local_name, sizeof (local_name), "local_%d", i); + snprintf (scratch_name, sizeof (scratch_name), "local_%d", i); stack[i] = gcc_jit_function_new_local (comp.func, NULL, comp.lisp_obj_type, - local_name); + scratch_name); } gcc_jit_block *prologue_bb = @@ -1557,27 +1558,41 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, { /* struct handler *c = push_handler (POP, type); */ int handler_pc = FETCH2; - gcc_jit_rvalue *c; + snprintf (scratch_name, sizeof (scratch_name), "c_%u", + pushhandler_n); + gcc_jit_lvalue *c = + gcc_jit_function_new_local (comp.func, + NULL, + comp.handler_ptr_type, + scratch_name); POP1; args[1] = gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.int_type, type); - c = emit_call ("push_handler", comp.handler_ptr_type, 2, args); + gcc_jit_block_add_assignment ( + comp.bblock->gcc_bb, + NULL, + c, + emit_call ("push_handler", comp.handler_ptr_type, 2, args)); + args[0] = gcc_jit_lvalue_get_address ( - gcc_jit_rvalue_dereference_field (c, - NULL, - comp.handler_jmp_field), - NULL); + gcc_jit_rvalue_dereference_field ( + gcc_jit_lvalue_as_rvalue (c), + NULL, + comp.handler_jmp_field), + NULL); #ifdef HAVE__SETJMP res = emit_call ("_setjmp", comp.int_type, 1, args); #else res = emit_call ("setjmp", comp.int_type, 1, args); #endif + snprintf (scratch_name, sizeof (scratch_name), "push_h_val_%u", + pushhandler_n); gcc_jit_block *push_h_val_block = - gcc_jit_function_new_block (comp.func, "push_h_val"); + gcc_jit_function_new_block (comp.func, scratch_name); emit_cond_jump ( - /* This negation is just to move to bool. */ + /* This negation is just to have a bool. */ gcc_jit_context_new_unary_op (comp.ctxt, NULL, GCC_JIT_UNARY_OP_LOGICAL_NEGATE, @@ -1598,18 +1613,19 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, m_handlerlist, gcc_jit_lvalue_as_rvalue( gcc_jit_rvalue_dereference_field ( - c, + gcc_jit_lvalue_as_rvalue (c), NULL, comp.handler_next_field))); /* PUSH (c->val); */ PUSH_LVAL ( - gcc_jit_rvalue_dereference_field (c, + gcc_jit_rvalue_dereference_field (gcc_jit_lvalue_as_rvalue (c), NULL, comp.handler_val_field)); *comp.bblock = bb_orig; gcc_jit_block_end_with_jump (push_h_val_block, NULL, bb_map[handler_pc].gcc_bb); + ++pushhandler_n; } break; commit b661d47434e54926f9612e9637d1feb763f653ef Author: Andrea Corallo Date: Sat Jun 22 17:13:31 2019 +0200 better emit_lisp_obj_from_ptr diff --git a/src/comp.c b/src/comp.c index 2b439fd2a5..74102c5536 100644 --- a/src/comp.c +++ b/src/comp.c @@ -671,22 +671,31 @@ static gcc_jit_rvalue * emit_lisp_obj_from_ptr (basic_block_t *bblock, void *p) { static unsigned i; - char ptr_var_name[40]; + char scratch[256]; - int res = snprintf (ptr_var_name, sizeof (ptr_var_name), + int res = snprintf (scratch, sizeof (scratch), "lisp_obj_from_ptr_%u", i++); - if (res >= sizeof (ptr_var_name)) + if (res >= sizeof (scratch)) error ("Internal error, truncating temporary variable"); gcc_jit_lvalue *lisp_obj = gcc_jit_function_new_local (comp.func, NULL, comp.lisp_obj_type, - ptr_var_name); + scratch); gcc_jit_rvalue *void_ptr = gcc_jit_context_new_rvalue_from_ptr(comp.ctxt, comp.void_ptr_type, p); + if (SYMBOLP (p)) + { + snprintf (scratch, sizeof (scratch), + "Symbol %s", (char *) SDATA (SYMBOL_NAME (p))); + gcc_jit_block_add_comment (bblock->gcc_bb, + NULL, + scratch); + } + gcc_jit_block_add_assignment (bblock->gcc_bb, NULL, emit_lval_XLP (lisp_obj), @@ -697,6 +706,8 @@ emit_lisp_obj_from_ptr (basic_block_t *bblock, void *p) static gcc_jit_rvalue * emit_scratch_callN (const char *f_name, unsigned nargs, gcc_jit_rvalue **args) { + char tmp_str[256]; + /* Here we set all the pointers into the scratch call area. */ /* TODO: distinguish primitives for faster calling convention. */ commit 7cbfd437a9bb2bcb5f4d776bb09572bb50965102 Author: Andrea Corallo Date: Sat Jun 22 17:13:03 2019 +0200 better logging into emit_scratch_callN diff --git a/src/comp.c b/src/comp.c index c724f46a9b..2b439fd2a5 100644 --- a/src/comp.c +++ b/src/comp.c @@ -712,6 +712,12 @@ emit_scratch_callN (const char *f_name, unsigned nargs, gcc_jit_rvalue **args) p[n] = 0x...; */ + snprintf (tmp_str, sizeof (tmp_str), "calling %s", f_name); + + gcc_jit_block_add_comment (comp.bblock->gcc_bb, + NULL, + tmp_str); + gcc_jit_lvalue *p = gcc_jit_function_new_local(comp.func, NULL, commit a31a164ea0b75c6523346fb9cc05233e036596d3 Author: Andrea Corallo Date: Sat Jun 22 17:12:35 2019 +0200 imrpve macros diff --git a/src/comp.c b/src/comp.c index 201ffa6559..c724f46a9b 100644 --- a/src/comp.c +++ b/src/comp.c @@ -125,15 +125,17 @@ along with GNU Emacs. If not, see . */ /* Pop from the meta-stack, emit the call and push the result */ #define EMIT_CALL_N(name, nargs) \ - POP##nargs; \ - res = emit_call (name, comp.lisp_obj_type, nargs, args); \ - PUSH_RVAL (res); + do { \ + POP##nargs; \ + res = emit_call (name, comp.lisp_obj_type, nargs, args); \ + PUSH_RVAL (res); \ + } while (0) /* Generate appropriate case and emit call to function. */ #define CASE_CALL_NARGS(name, nargs) \ case B##name: \ - EMIT_CALL_N (STR(F##name), nargs) \ + EMIT_CALL_N (STR(F##name), nargs); \ break /* Emit calls to functions with prototype (ptrdiff_t nargs, Lisp_Object *args) commit 8f0bb7d2647c0f5d4da5ec1af3ca1936ca42f221 Author: Andrea Corallo Date: Thu Jun 20 23:31:16 2019 +0200 rework debug dump diff --git a/src/comp.c b/src/comp.c index d08ec8c7c9..201ffa6559 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1111,8 +1111,12 @@ init_comp (int opt_level) } if (COMP_DEBUG > 1) { + gcc_jit_context_set_bool_option (comp.ctxt, + GCC_JIT_BOOL_OPTION_DEBUGINFO, + 1); + gcc_jit_context_dump_reproducer_to_file (comp.ctxt, "comp_reproducer.c"); - gcc_jit_context_dump_to_file (comp.ctxt, "emacs-gcc-code.c", 0); + } gcc_jit_context_set_int_option (comp.ctxt, @@ -1268,6 +1272,8 @@ init_comp (int opt_level) static void release_comp (void) { + if (COMP_DEBUG) + gcc_jit_context_dump_to_file (comp.ctxt, "gcc-ctxt-dump.c", 1); if (comp.ctxt) gcc_jit_context_release(comp.ctxt); commit 9cb5ce763d6e9ccb795704c1dfe0aa711b047426 Author: Andrea Corallo Date: Thu Jun 20 22:11:38 2019 +0200 name basic blocks diff --git a/src/comp.c b/src/comp.c index 0bc8be47a4..d08ec8c7c9 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1073,12 +1073,14 @@ compute_bblocks (ptrdiff_t bytestr_length, unsigned char *bytestr_data) } basic_block_t curr_bb; + char block_name[256]; for (int i = 0, pc = 0; pc < bytestr_length; pc++) { if (i < bb_n && pc == bb_start_pc[i]) { ++i; - curr_bb.gcc_bb = gcc_jit_function_new_block (comp.func, NULL); + snprintf (block_name, sizeof (block_name), "bb_%d", i); + curr_bb.gcc_bb = gcc_jit_function_new_block (comp.func, block_name); curr_bb.terminated = false; } bb_map[pc] = curr_bb; commit 3dde8c0e126d82663ad638c6dd63c8ee5f79c021 Author: Andrea Corallo Date: Mon Jun 17 15:37:08 2019 +0200 adding Bpushconditioncase Bpushcatch diff --git a/src/comp.c b/src/comp.c index c557fe9db5..0bc8be47a4 100644 --- a/src/comp.c +++ b/src/comp.c @@ -113,14 +113,14 @@ along with GNU Emacs. If not, see . */ #define FETCH (bytestr_data[pc++]) /* Fetch two bytes from the bytecode stream and make a 16-bit number - out of them. */ + out of them. */ #define FETCH2 (op = FETCH, op + (FETCH << 8)) #define STR(s) #s /* With most of the ops we need to do the same stuff so this macros are meant - to save some typing. */ + to save some typing. */ /* Pop from the meta-stack, emit the call and push the result */ @@ -161,7 +161,7 @@ typedef struct { bool terminated; } basic_block_t; -/* The compiler context */ +/* The compiler context */ typedef struct { gcc_jit_context *ctxt; @@ -180,7 +180,17 @@ typedef struct { gcc_jit_type *lisp_obj_ptr_type; gcc_jit_field *lisp_obj_as_ptr; gcc_jit_field *lisp_obj_as_num; + /* struct handler. */ gcc_jit_struct *handler; + gcc_jit_field *handler_jmp_field; + gcc_jit_field *handler_val_field; + gcc_jit_field *handler_next_field; + gcc_jit_type *handler_ptr_type; + /* struct thread_state. */ + gcc_jit_struct *thread_state; + gcc_jit_field *m_handlerlist; + gcc_jit_type *thread_state_ptr_type; + gcc_jit_rvalue *current_thread; /* libgccjit has really limited support for casting therefore this union will be used for the scope. */ gcc_jit_type *cast_union_type; @@ -198,8 +208,8 @@ typedef struct { gcc_jit_rvalue *lisp_int0; gcc_jit_function *pseudovectorp; gcc_jit_function *bool_to_lisp_obj; - basic_block_t *bblock; /* Current basic block */ - Lisp_Object func_hash; /* f_name -> gcc_func */ + basic_block_t *bblock; /* Current basic block */ + Lisp_Object func_hash; /* f_name -> gcc_func */ } comp_t; static comp_t comp; @@ -266,13 +276,13 @@ type_to_cast_field (gcc_jit_type *type) static gcc_jit_function * emit_func_declare (const char *f_name, gcc_jit_type *ret_type, unsigned nargs, gcc_jit_rvalue **args, - enum gcc_jit_function_kind kind, bool reusable) + enum gcc_jit_function_kind kind, bool reusable) { gcc_jit_param *param[4]; gcc_jit_type *type[4]; /* If args are passed types are extracted from that otherwise assume params */ - /* are all lisp objs. */ + /* are all lisp objs. */ if (args) for (int i = 0; i < nargs; i++) type[i] = gcc_jit_rvalue_get_type (args[i]); @@ -543,7 +553,7 @@ static gcc_jit_rvalue * emit_FIXNUMP (gcc_jit_rvalue *obj) { /* (! (((unsigned) (XLI (x) >> (USE_LSB_TAG ? 0 : FIXNUM_BITS)) - - (unsigned) (Lisp_Int0 >> !USE_LSB_TAG)) + - (unsigned) (Lisp_Int0 >> !USE_LSB_TAG)) & ((1 << INTTYPEBITS) - 1))) */ gcc_jit_rvalue *sh_res = @@ -653,8 +663,8 @@ emit_make_fixnum (gcc_jit_block *block, gcc_jit_rvalue *obj) return gcc_jit_lvalue_as_rvalue (res); } -/* Construct fill and return a lisp object form a raw pointer. */ -/* TODO should we pass the bb? */ +/* Construct fill and return a lisp object form a raw pointer. */ +/* TODO should we pass the bb? */ static gcc_jit_rvalue * emit_lisp_obj_from_ptr (basic_block_t *bblock, void *p) { @@ -735,9 +745,27 @@ emit_scratch_callN (const char *f_name, unsigned nargs, gcc_jit_rvalue **args) return emit_call (f_name, comp.lisp_obj_type, 2, args); } +/* struct handler definition */ + static void define_handler_struct (void) { + comp.handler = gcc_jit_context_new_opaque_struct (comp.ctxt, NULL, "handler"); + comp.handler_ptr_type = + gcc_jit_type_get_pointer (gcc_jit_struct_as_type (comp.handler)); + + comp.handler_jmp_field = gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.jmp_buf_type, + "jmp"); + comp.handler_val_field = gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.lisp_obj_type, + "val"); + comp.handler_next_field = gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.handler_ptr_type, + "next"); gcc_jit_field *fields[] = { gcc_jit_context_new_field (comp.ctxt, NULL, @@ -751,17 +779,11 @@ define_handler_struct (void) NULL, comp.int_type, "nonlocal_exit"), + comp.handler_val_field, + comp.handler_next_field, gcc_jit_context_new_field (comp.ctxt, NULL, - comp.lisp_obj_type, - "val"), - gcc_jit_context_new_field (comp.ctxt, - NULL, - comp.void_ptr_type, - "next"), - gcc_jit_context_new_field (comp.ctxt, - NULL, - comp.void_ptr_type, + comp.handler_ptr_type, "nextfree"), gcc_jit_context_new_field (comp.ctxt, NULL, @@ -771,10 +793,7 @@ define_handler_struct (void) NULL, comp.int_type, "bytecode_dest"), - gcc_jit_context_new_field (comp.ctxt, - NULL, - comp.jmp_buf_type, - "jmp"), + comp.handler_jmp_field, gcc_jit_context_new_field (comp.ctxt, NULL, comp.emacs_int_type, @@ -791,13 +810,55 @@ define_handler_struct (void) NULL, comp.int_type, "interrupt_input_blocked") }; - comp.handler = + gcc_jit_struct_set_fields (comp.handler, + NULL, + sizeof (fields) / sizeof (*fields), + fields); + +} + +static void +define_thread_state_struct (void) +{ + /* Partially opaque definition for `thread_state'. + Because we need to access just m_handlerlist hopefully this is requires + less manutention then the full deifnition. */ + + comp.m_handlerlist = gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.handler_ptr_type, + "m_handlerlist"); + gcc_jit_field *fields[] = + { gcc_jit_context_new_field ( + comp.ctxt, + NULL, + gcc_jit_context_new_array_type (comp.ctxt, + NULL, + comp.char_type, + offsetof (struct thread_state, + m_handlerlist)), + "pad0"), + comp.m_handlerlist, + gcc_jit_context_new_field ( + comp.ctxt, + NULL, + gcc_jit_context_new_array_type (comp.ctxt, + NULL, + comp.char_type, + sizeof (struct thread_state) + - offsetof (struct thread_state, + m_handlerlist) + - sizeof (struct handler *)), + "pad1") }; + + comp.thread_state = gcc_jit_context_new_struct_type (comp.ctxt, NULL, - "handler", - sizeof (fields) - / sizeof (*fields), + "thread_state", + sizeof (fields) / sizeof (*fields), fields); + comp.thread_state_ptr_type = + gcc_jit_type_get_pointer (gcc_jit_struct_as_type (comp.thread_state)); } /* Declare a substitute for PSEUDOVECTORP as inline function. */ @@ -948,8 +1009,6 @@ compute_bblocks (ptrdiff_t bytestr_length, unsigned char *bytestr_data) case Bvarbind7: case Bcall7: case Bunbind7: - case Bpushcatch: - case Bpushconditioncase: case Bstack_ref7: case Bstack_set2: pc += 2; @@ -989,6 +1048,9 @@ compute_bblocks (ptrdiff_t bytestr_length, unsigned char *bytestr_data) bb_start_pc[bb_n++] = op; new_bb = true; break; + /* Other ops changing bb */ + case Bpushcatch: + case Bpushconditioncase: case Bsub1: case Badd1: case Bnegate: @@ -1074,7 +1136,7 @@ init_comp (int opt_level) comp.void_ptr_type, "obj"); #else - /* 64-bit builds on MS-Windows, 32-bit builds with wide ints. */ + /* 64-bit builds on MS-Windows, 32-bit builds with wide ints. */ comp.lisp_obj_as_ptr = gcc_jit_context_new_field (comp.ctxt, NULL, comp.long_long_type, @@ -1192,6 +1254,11 @@ init_comp (int opt_level) comp.func_hash = CALLN (Fmake_hash_table, QCtest, Qequal, QCweakness, Qt); define_handler_struct (); + define_thread_state_struct (); + comp.current_thread = + gcc_jit_context_new_rvalue_from_ptr (comp.ctxt, + comp.thread_state_ptr_type, + current_thread); define_PSEUDOVECTORP (); define_bool_to_lisp_obj (); } @@ -1276,6 +1343,8 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, while (pc < bytestr_length) { + enum handlertype type; + /* If we are changing BB and the last was one wasn't terminated terminate it with a fall through. */ if (comp.bblock && comp.bblock->gcc_bb != bb_map[pc].gcc_bb && @@ -1429,14 +1498,92 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, emit_call ("helper_unbind_n", comp.lisp_obj_type, 1, args); } break; + case Bpophandler: - error ("Bpophandler unsupported bytecode\n"); - break; - case Bpushconditioncase: - error ("Bpushconditioncase unsupported bytecode\n"); - break; - case Bpushcatch: - error ("Bpushcatch unsupported bytecode\n"); + { + /* current_thread->m_handlerlist = + current_thread->m_handlerlist->next; */ + gcc_jit_lvalue *m_handlerlist = + gcc_jit_rvalue_dereference_field (comp.current_thread, + NULL, + comp.m_handlerlist); + + gcc_jit_block_add_assignment( + comp.bblock->gcc_bb, + NULL, + m_handlerlist, + gcc_jit_lvalue_as_rvalue ( + gcc_jit_rvalue_dereference_field ( + gcc_jit_lvalue_as_rvalue (m_handlerlist), + NULL, + comp.handler_next_field))); + break; + } + + case Bpushconditioncase: /* New in 24.4. */ + type = CATCHER; + goto pushhandler; + + case Bpushcatch: /* New in 24.4. */ + type = CONDITION_CASE;; + pushhandler: + { + /* struct handler *c = push_handler (POP, type); */ + int handler_pc = FETCH2; + gcc_jit_rvalue *c; + POP1; + args[1] = gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.int_type, + type); + c = emit_call ("push_handler", comp.handler_ptr_type, 2, args); + args[0] = + gcc_jit_lvalue_get_address ( + gcc_jit_rvalue_dereference_field (c, + NULL, + comp.handler_jmp_field), + NULL); +#ifdef HAVE__SETJMP + res = emit_call ("_setjmp", comp.int_type, 1, args); +#else + res = emit_call ("setjmp", comp.int_type, 1, args); +#endif + gcc_jit_block *push_h_val_block = + gcc_jit_function_new_block (comp.func, "push_h_val"); + emit_cond_jump ( + /* This negation is just to move to bool. */ + gcc_jit_context_new_unary_op (comp.ctxt, + NULL, + GCC_JIT_UNARY_OP_LOGICAL_NEGATE, + comp.bool_type, + res), + bb_map[pc].gcc_bb, + push_h_val_block); + + basic_block_t bb_orig = *comp.bblock; + comp.bblock->gcc_bb = push_h_val_block; + /* current_thread->m_handlerlist = c->next; */ + gcc_jit_lvalue *m_handlerlist = + gcc_jit_rvalue_dereference_field (comp.current_thread, + NULL, + comp.m_handlerlist); + gcc_jit_block_add_assignment(comp.bblock->gcc_bb, + NULL, + m_handlerlist, + gcc_jit_lvalue_as_rvalue( + gcc_jit_rvalue_dereference_field ( + c, + NULL, + comp.handler_next_field))); + /* PUSH (c->val); */ + PUSH_LVAL ( + gcc_jit_rvalue_dereference_field (c, + NULL, + comp.handler_val_field)); + *comp.bblock = bb_orig; + + gcc_jit_block_end_with_jump (push_h_val_block, NULL, + bb_map[handler_pc].gcc_bb); + } break; CASE_CALL_NARGS (nth, 2); @@ -1514,8 +1661,8 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, { /* (FIXNUMP (TOP) && XFIXNUM (TOP) != MOST_NEGATIVE_FIXNUM - ? make_fixnum (XFIXNUM (TOP) - 1) - : Fsub1 (TOP)) */ + ? make_fixnum (XFIXNUM (TOP) - 1) + : Fsub1 (TOP)) */ gcc_jit_block *sub1_inline_block = gcc_jit_function_new_block (comp.func, "inline_sub1"); @@ -1574,8 +1721,8 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, { /* (FIXNUMP (TOP) && XFIXNUM (TOP) != MOST_POSITIVE_FIXNUM - ? make_fixnum (XFIXNUM (TOP) + 1) - : Fadd (TOP)) */ + ? make_fixnum (XFIXNUM (TOP) + 1) + : Fadd (TOP)) */ gcc_jit_block *add1_inline_block = gcc_jit_function_new_block (comp.func, "inline_add1"); @@ -1793,7 +1940,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, comp.void_type, 0, NULL); break; - case Binteractive_p: /* Obsolete since 24.1. */ + case Binteractive_p: /* Obsolete since 24.1. */ PUSH_RVAL (emit_lisp_obj_from_ptr (comp.bblock, intern ("interactive-p"))); res = emit_call ("call0", comp.lisp_obj_type, 1, args); @@ -1891,7 +2038,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, emit_call ("record_unwind_protect", comp.void_ptr_type, 2, args); break; - case Bcatch: /* Obsolete since 24.4. */ + case Bcatch: /* Obsolete since 24.4. */ POP2; args[2] = args[1]; args[1] = emit_lisp_obj_from_ptr (comp.bblock, eval_sub); @@ -1903,17 +2050,17 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, emit_call ("helper_unwind_protect", comp.void_type, 1, args); break; - case Bcondition_case: /* Obsolete since 24.4. */ + case Bcondition_case: /* Obsolete since 24.4. */ POP3; emit_call ("internal_lisp_condition_case", comp.lisp_obj_type, 3, args); break; - case Btemp_output_buffer_setup: /* Obsolete since 24.1. */ + case Btemp_output_buffer_setup: /* Obsolete since 24.1. */ EMIT_CALL_N ("helper_temp_output_buffer_setup", 1); break; - case Btemp_output_buffer_show: /* Obsolete since 24.1. */ + case Btemp_output_buffer_show: /* Obsolete since 24.1. */ POP2; emit_call ("temp_output_buffer_show", comp.void_type, 1, &args[1]); @@ -1923,7 +2070,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, break; case Bunbind_all: /* Obsolete. Never used. */ /* To unbind back to the beginning of this frame. Not used yet, - but will be needed for tail-recursion elimination. */ + but will be needed for tail-recursion elimination. */ error ("Bunbind_all not supported"); break; @@ -2074,7 +2221,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, case Bswitch: error ("Bswitch not supported"); /* The cases of Bswitch that we handle (which in theory is - all of them) are done in Bconstant, below. This is done + all of them) are done in Bconstant, below. This is done due to a design issue with Bswitch -- it should have taken a constant pool index inline, but instead looks for a constant on the stack. */ @@ -2099,7 +2246,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, break; } - /* We're compiling Bswitch instead. */ + /* We're compiling Bswitch instead. */ ++pc; break; } @@ -2131,7 +2278,7 @@ emacs_native_compile (const char *lisp_f_name, const char *c_f_name, /* BYTESTR must have been produced by Emacs 20.2 or the earlier because they produced a raw 8-bit string for byte-code and now such a byte-code string is loaded as multibyte while raw 8-bit - characters converted to multibyte form. Thus, now we must + characters converted to multibyte form. Thus, now we must convert them back to the originally intended unibyte form. */ bytestr = Fstring_as_unibyte (bytestr); commit a9adf96df39ce12990cb98c318bf6ac1d2dfe27c Author: Andrea Corallo Date: Mon Jun 17 09:59:41 2019 +0200 more type definitions diff --git a/src/comp.c b/src/comp.c index cbba557011..c557fe9db5 100644 --- a/src/comp.c +++ b/src/comp.c @@ -167,6 +167,7 @@ typedef struct { gcc_jit_context *ctxt; gcc_jit_type *void_type; gcc_jit_type *bool_type; + gcc_jit_type *char_type; gcc_jit_type *int_type; gcc_jit_type *unsigned_type; gcc_jit_type *long_type; @@ -174,9 +175,12 @@ typedef struct { gcc_jit_type *emacs_int_type; gcc_jit_type *void_ptr_type; gcc_jit_type *ptrdiff_type; + gcc_jit_type *jmp_buf_type; gcc_jit_type *lisp_obj_type; + gcc_jit_type *lisp_obj_ptr_type; gcc_jit_field *lisp_obj_as_ptr; gcc_jit_field *lisp_obj_as_num; + gcc_jit_struct *handler; /* libgccjit has really limited support for casting therefore this union will be used for the scope. */ gcc_jit_type *cast_union_type; @@ -731,10 +735,75 @@ emit_scratch_callN (const char *f_name, unsigned nargs, gcc_jit_rvalue **args) return emit_call (f_name, comp.lisp_obj_type, 2, args); } +static void +define_handler_struct (void) +{ + gcc_jit_field *fields[] = + { gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.int_type, + "type"), + gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.lisp_obj_type, + "tag_or_ch"), + gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.int_type, + "nonlocal_exit"), + gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.lisp_obj_type, + "val"), + gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.void_ptr_type, + "next"), + gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.void_ptr_type, + "nextfree"), + gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.lisp_obj_ptr_type, + "bytecode_top"), + gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.int_type, + "bytecode_dest"), + gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.jmp_buf_type, + "jmp"), + gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.emacs_int_type, + "f_lisp_eval_depth"), + gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.ptrdiff_type, + "pdlcount"), + gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.int_type, + "poll_suppress_count"), + gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.int_type, + "interrupt_input_blocked") }; + comp.handler = + gcc_jit_context_new_struct_type (comp.ctxt, + NULL, + "handler", + sizeof (fields) + / sizeof (*fields), + fields); +} + /* Declare a substitute for PSEUDOVECTORP as inline function. */ static void -declare_PSEUDOVECTORP (void) +define_PSEUDOVECTORP (void) { gcc_jit_param *param[2] = { gcc_jit_context_new_param (comp.ctxt, @@ -800,7 +869,7 @@ declare_PSEUDOVECTORP (void) /* Declare a function to convert boolean into t or nil */ static void -declare_bool_to_lisp_obj (void) +define_bool_to_lisp_obj (void) { /* x ? Qt : Qnil */ gcc_jit_param *param = gcc_jit_context_new_param (comp.ctxt, @@ -989,6 +1058,7 @@ init_comp (int opt_level) comp.void_type = gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_VOID); comp.void_ptr_type = gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_VOID_PTR); + comp.char_type = gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_CHAR); comp.int_type = gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_INT); comp.unsigned_type = gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_UNSIGNED_INT); @@ -1023,13 +1093,15 @@ init_comp (int opt_level) comp.emacs_int_type, "num"); - gcc_jit_field *lisp_obj_fields[2] = { comp.lisp_obj_as_ptr, - comp.lisp_obj_as_num }; + gcc_jit_field *lisp_obj_fields[] = { comp.lisp_obj_as_ptr, + comp.lisp_obj_as_num }; comp.lisp_obj_type = gcc_jit_context_new_union_type (comp.ctxt, NULL, "LispObj", - 2, + sizeof (lisp_obj_fields) + / sizeof (*lisp_obj_fields), lisp_obj_fields); + comp.lisp_obj_ptr_type = gcc_jit_type_get_pointer (comp.lisp_obj_type); comp.cast_union_as_ll = gcc_jit_context_new_field (comp.ctxt, @@ -1057,7 +1129,7 @@ init_comp (int opt_level) comp.bool_type, "b"); - gcc_jit_field *cast_union_fields[5] = + gcc_jit_field *cast_union_fields[] = { comp.cast_union_as_ll, comp.cast_union_as_l, comp.cast_union_as_u, @@ -1067,8 +1139,8 @@ init_comp (int opt_level) gcc_jit_context_new_union_type (comp.ctxt, NULL, "cast_union", - sizeof (cast_union_fields) / - sizeof (*cast_union_fields), + sizeof (cast_union_fields) + / sizeof (*cast_union_fields), cast_union_fields); comp.most_positive_fixnum = gcc_jit_context_new_rvalue_from_long (comp.ctxt, @@ -1102,8 +1174,13 @@ init_comp (int opt_level) else eassert ("ptrdiff_t size not handled."); - comp.ptrdiff_type = gcc_jit_context_get_type(comp.ctxt, ptrdiff_t_gcc); + comp.ptrdiff_type = gcc_jit_context_get_type (comp.ctxt, ptrdiff_t_gcc); + /* Opaque definition for jmp_buf. */ + comp.jmp_buf_type = gcc_jit_context_new_array_type (comp.ctxt, + NULL, + comp.char_type, + sizeof (jmp_buf)); comp.scratch = gcc_jit_lvalue_get_address( gcc_jit_context_new_global (comp.ctxt, NULL, @@ -1114,8 +1191,9 @@ init_comp (int opt_level) comp.func_hash = CALLN (Fmake_hash_table, QCtest, Qequal, QCweakness, Qt); - declare_PSEUDOVECTORP (); - declare_bool_to_lisp_obj (); + define_handler_struct (); + define_PSEUDOVECTORP (); + define_bool_to_lisp_obj (); } static void commit 4665ad2c8968fcb1eb90391eb46615f23e27eb09 Author: Andrea Corallo Date: Mon Jun 17 09:18:17 2019 +0200 better macro usage diff --git a/src/comp.c b/src/comp.c index 54b3c8da2d..cbba557011 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1832,10 +1832,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, break; case Btemp_output_buffer_setup: /* Obsolete since 24.1. */ - POP1; - res = emit_call ("helper_temp_output_buffer_setup", comp.lisp_obj_type, - 1, args); - PUSH_RVAL (res); + EMIT_CALL_N ("helper_temp_output_buffer_setup", 1); break; case Btemp_output_buffer_show: /* Obsolete since 24.1. */ commit 09b33fb6bf12d55efa612a9ab3a20477047024de Author: Andrea Corallo Date: Sun Jun 16 22:04:43 2019 +0200 use emacs_int diff --git a/src/comp.c b/src/comp.c index 2da173f723..54b3c8da2d 100644 --- a/src/comp.c +++ b/src/comp.c @@ -171,6 +171,7 @@ typedef struct { gcc_jit_type *unsigned_type; gcc_jit_type *long_type; gcc_jit_type *long_long_type; + gcc_jit_type *emacs_int_type; gcc_jit_type *void_ptr_type; gcc_jit_type *ptrdiff_type; gcc_jit_type *lisp_obj_type; @@ -180,6 +181,7 @@ typedef struct { be used for the scope. */ gcc_jit_type *cast_union_type; gcc_jit_field *cast_union_as_ll; + gcc_jit_field *cast_union_as_l; gcc_jit_field *cast_union_as_u; gcc_jit_field *cast_union_as_i; gcc_jit_field *cast_union_as_b; @@ -243,6 +245,8 @@ type_to_cast_field (gcc_jit_type *type) if (type == comp.long_long_type) field = comp.cast_union_as_ll; + else if (type == comp.long_type) + field = comp.cast_union_as_l; else if (type == comp.unsigned_type) field = comp.cast_union_as_u; else if (type == comp.int_type) @@ -460,10 +464,10 @@ emit_TAGGEDP (gcc_jit_rvalue *obj, unsigned tag) comp.ctxt, NULL, GCC_JIT_BINARY_OP_RSHIFT, - comp.long_long_type, + comp.emacs_int_type, emit_rval_XLI (obj), gcc_jit_context_new_rvalue_from_int (comp.ctxt, - comp.long_long_type, + comp.emacs_int_type, (USE_LSB_TAG ? 0 : VALBITS))); gcc_jit_rvalue *minus_res = @@ -543,10 +547,10 @@ emit_FIXNUMP (gcc_jit_rvalue *obj) comp.ctxt, NULL, GCC_JIT_BINARY_OP_RSHIFT, - comp.long_long_type, + comp.emacs_int_type, emit_rval_XLI (obj), gcc_jit_context_new_rvalue_from_int (comp.ctxt, - comp.long_long_type, + comp.emacs_int_type, (USE_LSB_TAG ? 0 : FIXNUM_BITS))); gcc_jit_rvalue *minus_res = @@ -585,7 +589,7 @@ emit_XFIXNUM (gcc_jit_rvalue *obj) return gcc_jit_context_new_binary_op (comp.ctxt, NULL, GCC_JIT_BINARY_OP_RSHIFT, - comp.long_long_type, + comp.emacs_int_type, emit_rval_XLI (obj), comp.inttypebits); } @@ -621,14 +625,14 @@ emit_make_fixnum (gcc_jit_block *block, gcc_jit_rvalue *obj) gcc_jit_context_new_binary_op (comp.ctxt, NULL, GCC_JIT_BINARY_OP_LSHIFT, - comp.long_long_type, + comp.emacs_int_type, obj, comp.inttypebits); tmp = gcc_jit_context_new_binary_op (comp.ctxt, NULL, GCC_JIT_BINARY_OP_PLUS, - comp.long_long_type, + comp.emacs_int_type, tmp, comp.lisp_int0); @@ -999,23 +1003,26 @@ init_comp (int opt_level) NULL, comp.void_ptr_type, "obj"); - comp.lisp_obj_as_num = gcc_jit_context_new_field (comp.ctxt, - NULL, - comp.long_long_type, - "num"); - #else /* 64-bit builds on MS-Windows, 32-bit builds with wide ints. */ comp.lisp_obj_as_ptr = gcc_jit_context_new_field (comp.ctxt, NULL, comp.long_long_type, "obj"); - comp.lisp_obj_as_num = gcc_jit_context_new_field (comp.ctxt, - NULL, - comp.long_long_type, - "num"); #endif + if (sizeof (EMACS_INT) == sizeof (long)) + comp.emacs_int_type = comp.long_type; + else if (sizeof (EMACS_INT) == sizeof (long long)) + comp.emacs_int_type = comp.long_long_type; + else + error ("Unexpected EMACS_INT size."); + + comp.lisp_obj_as_num = gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.emacs_int_type, + "num"); + gcc_jit_field *lisp_obj_fields[2] = { comp.lisp_obj_as_ptr, comp.lisp_obj_as_num }; comp.lisp_obj_type = gcc_jit_context_new_union_type (comp.ctxt, @@ -1027,8 +1034,13 @@ init_comp (int opt_level) comp.cast_union_as_ll = gcc_jit_context_new_field (comp.ctxt, NULL, - comp.long_long_type, /* FIXME? */ + comp.long_long_type, "ll"); + comp.cast_union_as_l = + gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.long_type, + "l"); comp.cast_union_as_u = gcc_jit_context_new_field (comp.ctxt, NULL, @@ -1045,36 +1057,39 @@ init_comp (int opt_level) comp.bool_type, "b"); - gcc_jit_field *cast_union_fields[4] = + gcc_jit_field *cast_union_fields[5] = { comp.cast_union_as_ll, + comp.cast_union_as_l, comp.cast_union_as_u, comp.cast_union_as_i, comp.cast_union_as_b,}; - comp.cast_union_type = gcc_jit_context_new_union_type (comp.ctxt, - NULL, - "cast_union", - 4, - cast_union_fields); + comp.cast_union_type = + gcc_jit_context_new_union_type (comp.ctxt, + NULL, + "cast_union", + sizeof (cast_union_fields) / + sizeof (*cast_union_fields), + cast_union_fields); comp.most_positive_fixnum = gcc_jit_context_new_rvalue_from_long (comp.ctxt, - comp.long_long_type, /* FIXME? */ + comp.emacs_int_type, MOST_POSITIVE_FIXNUM); comp.most_negative_fixnum = gcc_jit_context_new_rvalue_from_long (comp.ctxt, - comp.long_long_type, /* FIXME? */ + comp.emacs_int_type, MOST_NEGATIVE_FIXNUM); comp.one = gcc_jit_context_new_rvalue_from_int (comp.ctxt, - comp.long_long_type, /* FIXME? */ + comp.emacs_int_type, 1); comp.inttypebits = gcc_jit_context_new_rvalue_from_int (comp.ctxt, - comp.long_long_type, /* FIXME? */ + comp.emacs_int_type, INTTYPEBITS); comp.lisp_int0 = gcc_jit_context_new_rvalue_from_int (comp.ctxt, - comp.long_long_type, /* FIXME? */ + comp.emacs_int_type, Lisp_Int0); enum gcc_jit_types ptrdiff_t_gcc; @@ -1452,7 +1467,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, gcc_jit_context_new_binary_op (comp.ctxt, NULL, GCC_JIT_BINARY_OP_MINUS, - comp.long_long_type, + comp.emacs_int_type, tos_as_num, comp.one); @@ -1512,7 +1527,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, gcc_jit_context_new_binary_op (comp.ctxt, NULL, GCC_JIT_BINARY_OP_PLUS, - comp.long_long_type, + comp.emacs_int_type, tos_as_num, comp.one); @@ -1596,7 +1611,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, gcc_jit_context_new_unary_op (comp.ctxt, NULL, GCC_JIT_UNARY_OP_MINUS, - comp.long_long_type, + comp.emacs_int_type, tos_as_num); gcc_jit_block_add_assignment (negate_inline_block, commit 72e2d6752ce09e8fb75f1ddc5094e7810eefebcc Author: Andrea Corallo Date: Sun Jun 16 16:34:14 2019 +0200 some renaming convention diff --git a/src/comp.c b/src/comp.c index 4f50c1cc7c..2da173f723 100644 --- a/src/comp.c +++ b/src/comp.c @@ -122,23 +122,28 @@ along with GNU Emacs. If not, see . */ /* With most of the ops we need to do the same stuff so this macros are meant to save some typing. */ -/* Generate appropriate case and emit convential calls to function. */ +/* Pop from the meta-stack, emit the call and push the result */ + +#define EMIT_CALL_N(name, nargs) \ + POP##nargs; \ + res = emit_call (name, comp.lisp_obj_type, nargs, args); \ + PUSH_RVAL (res); + +/* Generate appropriate case and emit call to function. */ #define CASE_CALL_NARGS(name, nargs) \ case B##name: \ - POP##nargs; \ - res = emit_call (STR(F##name), comp.lisp_obj_type, nargs, args); \ - PUSH_RVAL (res); \ + EMIT_CALL_N (STR(F##name), nargs) \ break /* Emit calls to functions with prototype (ptrdiff_t nargs, Lisp_Object *args) This is done aggregating args into the scratch_call_area. */ -#define EMIT_SCRATCH_CALL_N(name, nargs) \ - do { \ - pop (nargs, &stack, args); \ - res = emit_callN (name, nargs, args); \ - PUSH_RVAL (res); \ +#define EMIT_SCRATCH_CALL_N(name, nargs) \ + do { \ + pop (nargs, &stack, args); \ + res = emit_scratch_callN (name, nargs, args); \ + PUSH_RVAL (res); \ } while (0) #define EMIT_ARITHCOMPARE(comparison) \ @@ -151,7 +156,6 @@ along with GNU Emacs. If not, see . */ PUSH_RVAL (res); \ } while (0) - typedef struct { gcc_jit_block *gcc_bb; bool terminated; @@ -671,7 +675,7 @@ emit_lisp_obj_from_ptr (basic_block_t *bblock, void *p) } static gcc_jit_rvalue * -emit_callN (const char *f_name, unsigned nargs, gcc_jit_rvalue **args) +emit_scratch_callN (const char *f_name, unsigned nargs, gcc_jit_rvalue **args) { /* Here we set all the pointers into the scratch call area. */ /* TODO: distinguish primitives for faster calling convention. */ @@ -1303,7 +1307,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, { ptrdiff_t nargs = op + 1; pop (nargs, &stack, args); - res = emit_callN ("Ffuncall", nargs, args); + res = emit_scratch_callN ("Ffuncall", nargs, args); PUSH_RVAL (res); break; } @@ -1781,10 +1785,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, break; case Bsave_window_excursion: /* Obsolete since 24.1. */ - POP1; - res = emit_call ("helper_save_window_excursion", - comp.lisp_obj_type, 1, args); - PUSH_RVAL (res); + EMIT_CALL_N ("helper_save_window_excursion", 1); break; case Bsave_restriction: @@ -1843,15 +1844,11 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, CASE_CALL_NARGS (downcase, 1); case Bstringeqlsign: - POP2; - res = emit_call ("Fstring_equal", comp.lisp_obj_type, 2, args); - PUSH_RVAL (res); + EMIT_CALL_N ("Fstring_equal", 2); break; case Bstringlss: - POP2; - res = emit_call ("Fstring_lessp", comp.lisp_obj_type, 2, args); - PUSH_RVAL (res); + EMIT_CALL_N ("Fstring_lessp", 2); break; CASE_CALL_NARGS (equal, 2); @@ -1863,15 +1860,11 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, CASE_CALL_NARGS (setcdr, 2); case Bcar_safe: - POP2; - res = emit_call ("CAR_SAFE", comp.lisp_obj_type, 1, args); - PUSH_RVAL (res); + EMIT_CALL_N ("CAR_SAFE", 1); break; case Bcdr_safe: - POP2; - res = emit_call ("CDR_SAFE", comp.lisp_obj_type, 1, args); - PUSH_RVAL (res); + EMIT_CALL_N ("CDR_SAFE", 1); break; case Bnconc: commit bb45450e4b63c4a40689b8b797de275713197a79 Author: Andrea Corallo Date: Sun Jun 16 15:59:41 2019 +0200 Bcar_safe Bcdr_safe support diff --git a/src/comp.c b/src/comp.c index 65e480b5da..4f50c1cc7c 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1863,10 +1863,15 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, CASE_CALL_NARGS (setcdr, 2); case Bcar_safe: - error ("Bcar_safe not supported"); + POP2; + res = emit_call ("CAR_SAFE", comp.lisp_obj_type, 1, args); + PUSH_RVAL (res); break; + case Bcdr_safe: - error ("Bcdr_safe not supported"); + POP2; + res = emit_call ("CDR_SAFE", comp.lisp_obj_type, 1, args); + PUSH_RVAL (res); break; case Bnconc: @@ -2189,7 +2194,6 @@ Lisp_Object helper_unbind_n (int val); bool helper_PSEUDOVECTOR_TYPEP_XUNTAG (const union vectorlike_header *a, enum pvec_type code); - Lisp_Object helper_save_window_excursion (Lisp_Object v1) { diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 931b9e0609..6a643df9d3 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -45,11 +45,25 @@ "Testing cons car cdr." (defun comp-tests-list-f () (list 1 2 3)) + (defun comp-tests-car-safe-f (x) + ;; Bcar_safe + (car-safe x)) + (defun comp-tests-cdr-safe-f (x) + ;; Bcdr_safe + (cdr-safe x)) (byte-compile #'comp-tests-list-f) (native-compile #'comp-tests-list-f) - - (should (equal (comp-tests-list-f) '(1 2 3)))) + (byte-compile #'comp-tests-car-safe-f) + (native-compile #'comp-tests-car-safe-f) + (byte-compile #'comp-tests-cdr-safe-f) + (native-compile #'comp-tests-cdr-safe-f) + + (should (equal (comp-tests-list-f) '(1 2 3))) + (should (= (comp-tests-car-safe-f '(1 . 2)) 1)) + (should (null (comp-tests-car-safe-f 'a))) + (should (= (comp-tests-cdr-safe-f '(1 . 2)) 2)) + (should (null (comp-tests-cdr-safe-f 'a)))) (ert-deftest comp-tests-cons-car-cdr () "Testing cons car cdr." commit eefd7d819cbcd4f1996875a6b4932845841eb099 Author: Andrea Corallo Date: Sun Jun 16 15:38:15 2019 +0200 Bstack_set2 support diff --git a/src/comp.c b/src/comp.c index 134d1baabc..65e480b5da 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1961,7 +1961,12 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, break; case Bstack_set2: - error ("Bstack_set2 not supported"); + op = FETCH2; + POP1; + gcc_jit_block_add_assignment (comp.bblock->gcc_bb, + NULL, + *(stack - op), + args[0]); break; case BdiscardN: commit 1510e15c3c709130ded1569fb1faee4e885c0ff8 Author: Andrea Corallo Date: Sun Jun 16 15:32:29 2019 +0200 Binsert support diff --git a/src/comp.c b/src/comp.c index f19fc84479..134d1baabc 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1945,7 +1945,8 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, break; case BinsertN: - error ("BinsertN not supported"); + op = FETCH; + EMIT_SCRATCH_CALL_N ("Finsert", op); break; case Bstack_set: diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index f1acc42b8c..931b9e0609 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -314,12 +314,22 @@ (1+ (let ((a 1) (_b) (_c)) - a))) + a))) + (defun comp-tests-insertn-f (a b c d) + ;; Binsert + (insert a b c d)) (byte-compile #'comp-tests-discardn-f) (native-compile #'comp-tests-discardn-f) + (byte-compile #'comp-tests-insertn-f) + (native-compile #'comp-tests-insertn-f) - (should (= (comp-tests-discardn-f 10) 2))) + (should (= (comp-tests-discardn-f 10) 2)) + + (should (string= (with-temp-buffer + (comp-tests-insertn-f "a" "b" "c" "d") + (buffer-string)) + "abcd"))) (ert-deftest comp-tests-gc () "Try to do some longer computation to let the gc kick in." commit 0c7115c7b894c8e1655a0d5e482cc7ed8b231506 Author: Andrea Corallo Date: Sun Jun 16 12:40:23 2019 +0200 BdiscardN support diff --git a/src/comp.c b/src/comp.c index fd7e7beda1..f19fc84479 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1197,20 +1197,16 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, case Bstack_ref3: case Bstack_ref4: case Bstack_ref5: - { - PUSH_LVAL (stack_base[(stack - stack_base) - (op - Bstack_ref) - 1]); - break; - } + PUSH_LVAL (stack_base[(stack - stack_base) - (op - Bstack_ref) - 1]); + break; + case Bstack_ref6: - { - PUSH_LVAL (stack_base[(stack - stack_base) - FETCH - 1]); - break; - } + PUSH_LVAL (stack_base[(stack - stack_base) - FETCH - 1]); + break; + case Bstack_ref7: - { - PUSH_LVAL (stack_base[(stack - stack_base) - FETCH2 - 1]); - break; - } + PUSH_LVAL (stack_base[(stack - stack_base) - FETCH2 - 1]); + break; case Bvarref7: op = FETCH2; @@ -1966,8 +1962,20 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, case Bstack_set2: error ("Bstack_set2 not supported"); break; + case BdiscardN: - error ("BdiscardN not supported"); + op = FETCH; + if (op & 0x80) + { + op &= 0x7F; + POP1; + gcc_jit_block_add_assignment (comp.bblock->gcc_bb, + NULL, + *(stack - op - 1), + args[0]); + } + + stack -= op; break; case Bswitch: error ("Bswitch not supported"); @@ -1978,6 +1986,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, a constant on the stack. */ goto fail; break; + default: case Bconstant: { diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 9d1ee65e4e..f1acc42b8c 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -307,6 +307,20 @@ (should (eq (comp-tests-numberp-f 'a) nil)) (should (eq (comp-tests-numberp-f 3.5) t))) +(ert-deftest comp-tests-stack () + "Test some stack operation." + (defun comp-tests-discardn-f (x) + ;; BdiscardN + (1+ (let ((a 1) + (_b) + (_c)) + a))) + + (byte-compile #'comp-tests-discardn-f) + (native-compile #'comp-tests-discardn-f) + + (should (= (comp-tests-discardn-f 10) 2))) + (ert-deftest comp-tests-gc () "Try to do some longer computation to let the gc kick in." (dotimes (_ 100000) commit 04aafb7f66dff551d80040a53c482bde08bbc254 Author: Andrea Corallo Date: Sun Jun 16 12:08:48 2019 +0200 Bnumberp support diff --git a/src/comp.c b/src/comp.c index 7bdf1a8615..fd7e7beda1 100644 --- a/src/comp.c +++ b/src/comp.c @@ -504,6 +504,12 @@ emit_CONSP (gcc_jit_rvalue *obj) return emit_TAGGEDP (obj, Lisp_Cons); } +static gcc_jit_rvalue * +emit_FLOATP (gcc_jit_rvalue *obj) +{ + return emit_TAGGEDP (obj, Lisp_Float); +} + static gcc_jit_rvalue * emit_BIGNUMP (gcc_jit_rvalue *obj) { @@ -592,6 +598,18 @@ emit_INTEGERP (gcc_jit_rvalue *obj) emit_BIGNUMP (obj)); } +static gcc_jit_rvalue * +emit_NUMBERP (gcc_jit_rvalue *obj) +{ + return gcc_jit_context_new_binary_op (comp.ctxt, + NULL, + GCC_JIT_BINARY_OP_LOGICAL_OR, + comp.bool_type, + emit_INTEGERP(obj), + emit_cast (comp.bool_type, + emit_FLOATP (obj))); +} + static gcc_jit_rvalue * emit_make_fixnum (gcc_jit_block *block, gcc_jit_rvalue *obj) { @@ -1866,7 +1884,13 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, CASE_CALL_NARGS (rem, 2); case Bnumberp: - error ("Bnumberp not supported"); + POP1; + res = emit_NUMBERP (args[0]); + res = gcc_jit_context_new_call (comp.ctxt, + NULL, + comp.bool_to_lisp_obj, + 1, &res); + PUSH_RVAL (res); break; case Bintegerp: diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 99dce77dc2..9d1ee65e4e 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -289,14 +289,23 @@ (defun comp-tests-integerp-f (x) ;; Bintegerp (integerp x)) + (defun comp-tests-numberp-f (x) + ;; Bnumberp + (numberp x)) (byte-compile #'comp-tests-integerp-f) (native-compile #'comp-tests-integerp-f) + (byte-compile #'comp-tests-numberp-f) + (native-compile #'comp-tests-numberp-f) (should (eq (comp-tests-integerp-f 1) t)) (should (eq (comp-tests-integerp-f '(1)) nil)) (should (eq (comp-tests-integerp-f 3.5) nil)) - (should (eq (comp-tests-integerp-f (1+ most-negative-fixnum)) t))) + (should (eq (comp-tests-integerp-f (1+ most-negative-fixnum)) t)) + + (should (eq (comp-tests-numberp-f 1) t)) + (should (eq (comp-tests-numberp-f 'a) nil)) + (should (eq (comp-tests-numberp-f 3.5) t))) (ert-deftest comp-tests-gc () "Try to do some longer computation to let the gc kick in." commit 96e1a5efb3bdeb9e70f7ea6030514e83e6ae8da1 Author: Andrea Corallo Date: Sun Jun 16 11:59:11 2019 +0200 fix consp diff --git a/src/comp.c b/src/comp.c index f3fd8dc16b..7bdf1a8615 100644 --- a/src/comp.c +++ b/src/comp.c @@ -495,13 +495,13 @@ emit_TAGGEDP (gcc_jit_rvalue *obj, unsigned tag) static gcc_jit_rvalue * emit_VECTORLIKEP (gcc_jit_rvalue *obj) { - return emit_TAGGEDP(obj, Lisp_Vectorlike); + return emit_TAGGEDP (obj, Lisp_Vectorlike); } static gcc_jit_rvalue * emit_CONSP (gcc_jit_rvalue *obj) { - return emit_TAGGEDP(obj, Lisp_Cons); + return emit_TAGGEDP (obj, Lisp_Cons); } static gcc_jit_rvalue * @@ -1332,11 +1332,14 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, CASE_CALL_NARGS (symbolp, 1); case Bconsp: - gcc_jit_block_add_assignment ( - comp.bblock->gcc_bb, - NULL, - TOS, - emit_CONSP(gcc_jit_lvalue_as_rvalue (TOS))); + POP1; + res = emit_cast (comp.bool_type, + emit_CONSP (args[0])); + res = gcc_jit_context_new_call (comp.ctxt, + NULL, + comp.bool_to_lisp_obj, + 1, &res); + PUSH_RVAL (res); break; CASE_CALL_NARGS (stringp, 1); diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index d7e6954455..99dce77dc2 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -278,8 +278,8 @@ ;; Bconsp (consp x)) - ;; (byte-compile #'comp-tests-consp-f) - ;; (native-compile #'comp-tests-consp-f) + (byte-compile #'comp-tests-consp-f) + (native-compile #'comp-tests-consp-f) (should (eq (comp-tests-consp-f '(1)) t)) (should (eq (comp-tests-consp-f 1) nil))) commit 2a1bb41c14fba3ecb2f7ccdb251918ea0ac30c41 Author: Andrea Corallo Date: Sun Jun 16 11:21:29 2019 +0200 Bintegerp support diff --git a/src/comp.c b/src/comp.c index 1b1401caff..f3fd8dc16b 100644 --- a/src/comp.c +++ b/src/comp.c @@ -187,6 +187,7 @@ typedef struct { gcc_jit_rvalue *inttypebits; gcc_jit_rvalue *lisp_int0; gcc_jit_function *pseudovectorp; + gcc_jit_function *bool_to_lisp_obj; basic_block_t *bblock; /* Current basic block */ Lisp_Object func_hash; /* f_name -> gcc_func */ } comp_t; @@ -360,7 +361,7 @@ emit_call (const char *f_name, gcc_jit_type *ret_type, unsigned nargs, INLINE static void emit_cond_jump (gcc_jit_rvalue *test, - gcc_jit_block *then_target, gcc_jit_block *else_target) + gcc_jit_block *then_target, gcc_jit_block *else_target) { gcc_jit_block_end_with_conditional (comp.bblock->gcc_bb, NULL, @@ -503,72 +504,6 @@ emit_CONSP (gcc_jit_rvalue *obj) return emit_TAGGEDP(obj, Lisp_Cons); } -/* Declare a substitute for PSEUDOVECTORP as inline function. */ - -static void -declare_PSEUDOVECTORP (void) -{ - gcc_jit_param *param[2] = - { gcc_jit_context_new_param (comp.ctxt, - NULL, - comp.lisp_obj_type, - "a"), - gcc_jit_context_new_param (comp.ctxt, - NULL, - comp.int_type, - "code") }; - - comp.pseudovectorp = - gcc_jit_context_new_function (comp.ctxt, NULL, - GCC_JIT_FUNCTION_ALWAYS_INLINE, - comp.bool_type, - "PSEUDOVECTORP", - 2, - param, - 0); - - gcc_jit_block *initial_block = - gcc_jit_function_new_block (comp.pseudovectorp, "PSEUDOVECTORP_initial_block"); - - gcc_jit_block *ret_false_b = - gcc_jit_function_new_block (comp.pseudovectorp, "ret_false"); - - gcc_jit_block *call_pseudovector_typep_b = - gcc_jit_function_new_block (comp.pseudovectorp, "call_pseudovector"); - - /* Set current context as needed */ - basic_block_t bblock = { .gcc_bb = initial_block, - .terminated = false }; - comp.bblock = &bblock; - comp.func = comp.pseudovectorp; - - emit_cond_jump ( - emit_cast (comp.bool_type, - emit_VECTORLIKEP (gcc_jit_param_as_rvalue (param[0]))), - call_pseudovector_typep_b, - ret_false_b); - - comp.bblock->gcc_bb = ret_false_b; - gcc_jit_block_end_with_return (ret_false_b, - NULL, - gcc_jit_context_new_rvalue_from_int( - comp.ctxt, - comp.bool_type, - false)); - - gcc_jit_rvalue *args[2] = - { gcc_jit_param_as_rvalue (param[0]), - gcc_jit_param_as_rvalue (param[1]) }; - comp.bblock->gcc_bb = call_pseudovector_typep_b; - /* FIXME XUNTAG missing here. */ - gcc_jit_block_end_with_return (call_pseudovector_typep_b, - NULL, - emit_call ("helper_PSEUDOVECTOR_TYPEP_XUNTAG", - comp.bool_type, - 2, - args)); -} - static gcc_jit_rvalue * emit_BIGNUMP (gcc_jit_rvalue *obj) { @@ -579,10 +514,11 @@ emit_BIGNUMP (gcc_jit_rvalue *obj) comp.int_type, PVEC_BIGNUM) }; - return emit_call ("PSEUDOVECTORP", - comp.bool_type, - 2, - args); + return gcc_jit_context_new_call (comp.ctxt, + NULL, + comp.pseudovectorp, + 2, + args); } static gcc_jit_rvalue * @@ -651,7 +587,8 @@ emit_INTEGERP (gcc_jit_rvalue *obj) NULL, GCC_JIT_BINARY_OP_LOGICAL_OR, comp.bool_type, - emit_FIXNUMP (obj), + emit_cast (comp.bool_type, + emit_FIXNUMP (obj)), emit_BIGNUMP (obj)); } @@ -687,7 +624,7 @@ emit_make_fixnum (gcc_jit_block *block, gcc_jit_rvalue *obj) } /* Construct fill and return a lisp object form a raw pointer. */ - +/* TODO should we pass the bb? */ static gcc_jit_rvalue * emit_lisp_obj_from_ptr (basic_block_t *bblock, void *p) { @@ -745,16 +682,19 @@ emit_callN (const char *f_name, unsigned nargs, gcc_jit_rvalue **args) for (int i = 0; i < nargs; i++) { gcc_jit_rvalue *idx = - gcc_jit_context_new_rvalue_from_int (comp.ctxt, - gcc_jit_context_get_type(comp.ctxt, - GCC_JIT_TYPE_UNSIGNED_INT), - i); - gcc_jit_block_add_assignment (comp.bblock->gcc_bb, NULL, - gcc_jit_context_new_array_access (comp.ctxt, - NULL, - gcc_jit_lvalue_as_rvalue(p), - idx), - args[i]); + gcc_jit_context_new_rvalue_from_int ( + comp.ctxt, + gcc_jit_context_get_type(comp.ctxt, + GCC_JIT_TYPE_UNSIGNED_INT), + i); + gcc_jit_block_add_assignment ( + comp.bblock->gcc_bb, + NULL, + gcc_jit_context_new_array_access (comp.ctxt, + NULL, + gcc_jit_lvalue_as_rvalue(p), + idx), + args[i]); } args[0] = gcc_jit_context_new_rvalue_from_int(comp.ctxt, @@ -765,6 +705,118 @@ emit_callN (const char *f_name, unsigned nargs, gcc_jit_rvalue **args) return emit_call (f_name, comp.lisp_obj_type, 2, args); } +/* Declare a substitute for PSEUDOVECTORP as inline function. */ + +static void +declare_PSEUDOVECTORP (void) +{ + gcc_jit_param *param[2] = + { gcc_jit_context_new_param (comp.ctxt, + NULL, + comp.lisp_obj_type, + "a"), + gcc_jit_context_new_param (comp.ctxt, + NULL, + comp.int_type, + "code") }; + + comp.pseudovectorp = + gcc_jit_context_new_function (comp.ctxt, NULL, + GCC_JIT_FUNCTION_ALWAYS_INLINE, + comp.bool_type, + "PSEUDOVECTORP", + 2, + param, + 0); + + gcc_jit_block *initial_block = + gcc_jit_function_new_block (comp.pseudovectorp, "PSEUDOVECTORP_initial_block"); + + gcc_jit_block *ret_false_b = + gcc_jit_function_new_block (comp.pseudovectorp, "ret_false"); + + gcc_jit_block *call_pseudovector_typep_b = + gcc_jit_function_new_block (comp.pseudovectorp, "call_pseudovector"); + + /* Set current context as needed */ + basic_block_t bblock = { .gcc_bb = initial_block, + .terminated = false }; + comp.bblock = &bblock; + comp.func = comp.pseudovectorp; + + emit_cond_jump ( + emit_cast (comp.bool_type, + emit_VECTORLIKEP (gcc_jit_param_as_rvalue (param[0]))), + call_pseudovector_typep_b, + ret_false_b); + + comp.bblock->gcc_bb = ret_false_b; + gcc_jit_block_end_with_return (ret_false_b, + NULL, + gcc_jit_context_new_rvalue_from_int( + comp.ctxt, + comp.bool_type, + false)); + + gcc_jit_rvalue *args[2] = + { gcc_jit_param_as_rvalue (param[0]), + gcc_jit_param_as_rvalue (param[1]) }; + comp.bblock->gcc_bb = call_pseudovector_typep_b; + /* FIXME XUNTAG missing here. */ + gcc_jit_block_end_with_return (call_pseudovector_typep_b, + NULL, + emit_call ("helper_PSEUDOVECTOR_TYPEP_XUNTAG", + comp.bool_type, + 2, + args)); +} + +/* Declare a function to convert boolean into t or nil */ + +static void +declare_bool_to_lisp_obj (void) +{ + /* x ? Qt : Qnil */ + gcc_jit_param *param = gcc_jit_context_new_param (comp.ctxt, + NULL, + comp.bool_type, + "x"); + comp.bool_to_lisp_obj = + gcc_jit_context_new_function (comp.ctxt, NULL, + GCC_JIT_FUNCTION_ALWAYS_INLINE, + comp.lisp_obj_type, + "bool_to_lisp_obj", + 1, + ¶m, + 0); + gcc_jit_block *initial_block = + gcc_jit_function_new_block (comp.bool_to_lisp_obj, + "bool_to_lisp_obj_initial_block"); + gcc_jit_block *ret_t_block = + gcc_jit_function_new_block (comp.bool_to_lisp_obj, + "ret_t"); + gcc_jit_block *ret_nil_block = + gcc_jit_function_new_block (comp.bool_to_lisp_obj, + "ret_nil"); + /* Set current context as needed */ + basic_block_t bblock = { .gcc_bb = initial_block, + .terminated = false }; + comp.bblock = &bblock; + comp.func = comp.bool_to_lisp_obj; + + emit_cond_jump (gcc_jit_param_as_rvalue (param), + ret_t_block, + ret_nil_block); + bblock.gcc_bb = ret_t_block; + gcc_jit_block_end_with_return (ret_t_block, + NULL, + emit_lisp_obj_from_ptr (&bblock, Qt)); + bblock.gcc_bb = ret_nil_block; + gcc_jit_block_end_with_return (ret_nil_block, + NULL, + emit_lisp_obj_from_ptr (&bblock, Qnil)); +} + static int ucmp(const void *a, const void *b) { @@ -1026,6 +1078,7 @@ init_comp (int opt_level) comp.func_hash = CALLN (Fmake_hash_table, QCtest, Qequal, QCweakness, Qt); declare_PSEUDOVECTORP (); + declare_bool_to_lisp_obj (); } static void @@ -1814,7 +1867,13 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, break; case Bintegerp: - error ("Bintegerp not supported"); + POP1; + res = emit_INTEGERP(args[0]); + res = gcc_jit_context_new_call (comp.ctxt, + NULL, + comp.bool_to_lisp_obj, + 1, &res); + PUSH_RVAL (res); break; case BRgoto: diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 63dfafafb0..d7e6954455 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -278,9 +278,26 @@ ;; Bconsp (consp x)) + ;; (byte-compile #'comp-tests-consp-f) + ;; (native-compile #'comp-tests-consp-f) + (should (eq (comp-tests-consp-f '(1)) t)) (should (eq (comp-tests-consp-f 1) nil))) +(ert-deftest comp-tests-num-inline () + "Test some inlined number functions." + (defun comp-tests-integerp-f (x) + ;; Bintegerp + (integerp x)) + + (byte-compile #'comp-tests-integerp-f) + (native-compile #'comp-tests-integerp-f) + + (should (eq (comp-tests-integerp-f 1) t)) + (should (eq (comp-tests-integerp-f '(1)) nil)) + (should (eq (comp-tests-integerp-f 3.5) nil)) + (should (eq (comp-tests-integerp-f (1+ most-negative-fixnum)) t))) + (ert-deftest comp-tests-gc () "Try to do some longer computation to let the gc kick in." (dotimes (_ 100000) commit 0438e245a15e91aac93a5df812ce292dd1ff681b Author: Andrea Corallo Date: Sat Jun 15 18:38:20 2019 +0200 add emit_INTEGERP diff --git a/src/comp.c b/src/comp.c index a18ed07391..1b1401caff 100644 --- a/src/comp.c +++ b/src/comp.c @@ -572,6 +572,7 @@ declare_PSEUDOVECTORP (void) static gcc_jit_rvalue * emit_BIGNUMP (gcc_jit_rvalue *obj) { + /* PSEUDOVECTORP (x, PVEC_BIGNUM); */ gcc_jit_rvalue *args[2] = { obj, gcc_jit_context_new_rvalue_from_int (comp.ctxt, @@ -643,6 +644,17 @@ emit_XFIXNUM (gcc_jit_rvalue *obj) comp.inttypebits); } +static gcc_jit_rvalue * +emit_INTEGERP (gcc_jit_rvalue *obj) +{ + return gcc_jit_context_new_binary_op (comp.ctxt, + NULL, + GCC_JIT_BINARY_OP_LOGICAL_OR, + comp.bool_type, + emit_FIXNUMP (obj), + emit_BIGNUMP (obj)); +} + static gcc_jit_rvalue * emit_make_fixnum (gcc_jit_block *block, gcc_jit_rvalue *obj) { commit cb4ce8b31c53a927f8ec8b542ad90acd14e951de Author: Andrea Corallo Date: Sat Jun 15 18:34:18 2019 +0200 add emit_BIGNUMP diff --git a/src/comp.c b/src/comp.c index e74e67d117..a18ed07391 100644 --- a/src/comp.c +++ b/src/comp.c @@ -503,13 +503,6 @@ emit_CONSP (gcc_jit_rvalue *obj) return emit_TAGGEDP(obj, Lisp_Cons); } -/* static gcc_jit_rvalue * */ -/* emit_BIGNUMP (gcc_jit_rvalue *obj) */ -/* { */ - -/* } */ - - /* Declare a substitute for PSEUDOVECTORP as inline function. */ static void @@ -576,6 +569,21 @@ declare_PSEUDOVECTORP (void) args)); } +static gcc_jit_rvalue * +emit_BIGNUMP (gcc_jit_rvalue *obj) +{ + gcc_jit_rvalue *args[2] = { + obj, + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.int_type, + PVEC_BIGNUM) }; + + return emit_call ("PSEUDOVECTORP", + comp.bool_type, + 2, + args); +} + static gcc_jit_rvalue * emit_FIXNUMP (gcc_jit_rvalue *obj) { commit f245990714abfd33c869573ebc2ba91eaa336e59 Author: Andrea Corallo Date: Sat Jun 15 18:31:41 2019 +0200 emit_call funcs return now rval diff --git a/src/comp.c b/src/comp.c index caa5cc9600..e74e67d117 100644 --- a/src/comp.c +++ b/src/comp.c @@ -128,7 +128,7 @@ along with GNU Emacs. If not, see . */ case B##name: \ POP##nargs; \ res = emit_call (STR(F##name), comp.lisp_obj_type, nargs, args); \ - PUSH_LVAL (res); \ + PUSH_RVAL (res); \ break /* Emit calls to functions with prototype (ptrdiff_t nargs, Lisp_Object *args) @@ -138,7 +138,7 @@ along with GNU Emacs. If not, see . */ do { \ pop (nargs, &stack, args); \ res = emit_callN (name, nargs, args); \ - PUSH_LVAL (res); \ + PUSH_RVAL (res); \ } while (0) #define EMIT_ARITHCOMPARE(comparison) \ @@ -148,7 +148,7 @@ along with GNU Emacs. If not, see . */ comp.int_type, \ comparison); \ res = emit_call ("arithcompare", comp.lisp_obj_type, 3, args); \ - PUSH_LVAL (res); \ + PUSH_RVAL (res); \ } while (0) @@ -329,10 +329,9 @@ emit_func_declare (const char *f_name, gcc_jit_type *ret_type, return func; } -/* TODO this should return an rval */ -static gcc_jit_lvalue * +static gcc_jit_rvalue * emit_call (const char *f_name, gcc_jit_type *ret_type, unsigned nargs, - gcc_jit_rvalue **args) + gcc_jit_rvalue **args) { Lisp_Object key = make_string (f_name, strlen (f_name)); EMACS_UINT hash = 0; @@ -350,18 +349,11 @@ emit_call (const char *f_name, gcc_jit_type *ret_type, unsigned nargs, Lisp_Object value = HASH_VALUE (ht, hash_lookup (ht, key, &hash)); gcc_jit_function *func = (gcc_jit_function *) XFIXNUMPTR (value); - gcc_jit_lvalue *res = gcc_jit_function_new_local(comp.func, - NULL, - ret_type, - "res"); - gcc_jit_block_add_assignment(comp.bblock->gcc_bb, NULL, - res, - gcc_jit_context_new_call(comp.ctxt, - NULL, - func, - nargs, - args)); - return res; + return gcc_jit_context_new_call(comp.ctxt, + NULL, + func, + nargs, + args); } /* Close current basic block emitting a conditional. */ @@ -578,12 +570,10 @@ declare_PSEUDOVECTORP (void) /* FIXME XUNTAG missing here. */ gcc_jit_block_end_with_return (call_pseudovector_typep_b, NULL, - gcc_jit_lvalue_as_rvalue( - emit_call ( - "helper_PSEUDOVECTOR_TYPEP_XUNTAG", - comp.bool_type, - 2, - args))); + emit_call ("helper_PSEUDOVECTOR_TYPEP_XUNTAG", + comp.bool_type, + 2, + args)); } static gcc_jit_rvalue * @@ -705,7 +695,7 @@ emit_lisp_obj_from_ptr (basic_block_t *bblock, void *p) return gcc_jit_lvalue_as_rvalue (lisp_obj); } -static gcc_jit_lvalue * +static gcc_jit_rvalue * emit_callN (const char *f_name, unsigned nargs, gcc_jit_rvalue **args) { /* Here we set all the pointers into the scratch call area. */ @@ -1034,7 +1024,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, EMACS_INT stack_depth, Lisp_Object *vectorp, ptrdiff_t vector_size, Lisp_Object args_template) { - gcc_jit_lvalue *res; + gcc_jit_rvalue *res; comp_f_res_t comp_res = { NULL, 0, 0 }; ptrdiff_t pc = 0; gcc_jit_rvalue *args[4]; @@ -1150,7 +1140,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, { args[0] = emit_lisp_obj_from_ptr (comp.bblock, vectorp[op]); res = emit_call ("Fsymbol_value", comp.lisp_obj_type, 1, args); - PUSH_LVAL (res); + PUSH_RVAL (res); break; } @@ -1179,7 +1169,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, comp.int_type, SET_INTERNAL_SET); res = emit_call ("set_internal", comp.lisp_obj_type, 4, args); - PUSH_LVAL (res); + PUSH_RVAL (res); } break; @@ -1203,7 +1193,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, args[0] = emit_lisp_obj_from_ptr (comp.bblock, vectorp[op]); pop (1, &stack, &args[1]); res = emit_call ("specbind", comp.lisp_obj_type, 2, args); - PUSH_LVAL (res); + PUSH_RVAL (res); break; } @@ -1227,7 +1217,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, ptrdiff_t nargs = op + 1; pop (nargs, &stack, args); res = emit_callN ("Ffuncall", nargs, args); - PUSH_LVAL (res); + PUSH_RVAL (res); break; } @@ -1299,12 +1289,12 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, POP1; args[1] = nil; res = emit_call ("Fcons", comp.lisp_obj_type, 2, args); - PUSH_LVAL (res); + PUSH_RVAL (res); for (int i = 0; i < op; ++i) { POP2; res = emit_call ("Fcons", comp.lisp_obj_type, 2, args); - PUSH_LVAL (res); + PUSH_RVAL (res); } break; } @@ -1382,7 +1372,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, comp.bblock->gcc_bb = sub1_fcall_block; POP1; res = emit_call ("Fsub1", comp.lisp_obj_type, 1, args); - PUSH_LVAL (res); + PUSH_RVAL (res); *comp.bblock = bb_orig; @@ -1442,7 +1432,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, comp.bblock->gcc_bb = add1_fcall_block; POP1; res = emit_call ("Fadd1", comp.lisp_obj_type, 1, args); - PUSH_LVAL (res); + PUSH_RVAL (res); *comp.bblock = bb_orig; @@ -1553,7 +1543,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, comp.lisp_obj_type, 1, args); - PUSH_LVAL (res); + PUSH_RVAL (res); break; CASE_CALL_NARGS (goto_char, 1); @@ -1571,7 +1561,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, comp.lisp_obj_type, 1, args); - PUSH_LVAL (res); + PUSH_RVAL (res); break; case Bpoint_min: @@ -1583,7 +1573,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, comp.lisp_obj_type, 1, args); - PUSH_LVAL (res); + PUSH_RVAL (res); break; CASE_CALL_NARGS (char_after, 1); @@ -1591,7 +1581,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, case Bpreceding_char: res = emit_call ("Fprevious_char", comp.lisp_obj_type, 0, args); - PUSH_LVAL (res); + PUSH_RVAL (res); break; CASE_CALL_NARGS (current_column, 0); @@ -1600,7 +1590,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, POP1; args[1] = nil; res = emit_call ("Findent_to", comp.lisp_obj_type, 2, args); - PUSH_LVAL (res); + PUSH_RVAL (res); break; CASE_CALL_NARGS (eolp, 0); @@ -1620,7 +1610,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, PUSH_RVAL (emit_lisp_obj_from_ptr (comp.bblock, intern ("interactive-p"))); res = emit_call ("call0", comp.lisp_obj_type, 1, args); - PUSH_LVAL (res); + PUSH_RVAL (res); break; CASE_CALL_NARGS (forward_char, 1); @@ -1704,17 +1694,16 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, POP1; res = emit_call ("helper_save_window_excursion", comp.lisp_obj_type, 1, args); - PUSH_LVAL (res); + PUSH_RVAL (res); break; case Bsave_restriction: args[0] = emit_lisp_obj_from_ptr (comp.bblock, save_restriction_restore); - args[1] = - gcc_jit_lvalue_as_rvalue (emit_call ("save_restriction_save", - comp.lisp_obj_type, - 0, - NULL)); + args[1] = emit_call ("save_restriction_save", + comp.lisp_obj_type, + 0, + NULL); emit_call ("record_unwind_protect", comp.void_ptr_type, 2, args); break; @@ -1740,7 +1729,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, POP1; res = emit_call ("helper_temp_output_buffer_setup", comp.lisp_obj_type, 1, args); - PUSH_LVAL (res); + PUSH_RVAL (res); break; case Btemp_output_buffer_show: /* Obsolete since 24.1. */ @@ -1766,13 +1755,13 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, case Bstringeqlsign: POP2; res = emit_call ("Fstring_equal", comp.lisp_obj_type, 2, args); - PUSH_LVAL (res); + PUSH_RVAL (res); break; case Bstringlss: POP2; res = emit_call ("Fstring_lessp", comp.lisp_obj_type, 2, args); - PUSH_LVAL (res); + PUSH_RVAL (res); break; CASE_CALL_NARGS (equal, 2); commit 433108104abecb5e84f28a476b9b977c0086694f Author: Andrea Corallo Date: Sat Jun 15 18:09:49 2019 +0200 helper_PSEUDOVECTOR_TYPEP -> helper_PSEUDOVECTOR_TYPEP_XUNTAG diff --git a/src/comp.c b/src/comp.c index b4774b9c33..caa5cc9600 100644 --- a/src/comp.c +++ b/src/comp.c @@ -579,10 +579,11 @@ declare_PSEUDOVECTORP (void) gcc_jit_block_end_with_return (call_pseudovector_typep_b, NULL, gcc_jit_lvalue_as_rvalue( - emit_call ("helper_PSEUDOVECTOR_TYPEP", - comp.bool_type, - 2, - args))); + emit_call ( + "helper_PSEUDOVECTOR_TYPEP_XUNTAG", + comp.bool_type, + 2, + args))); } static gcc_jit_rvalue * @@ -2076,8 +2077,8 @@ Lisp_Object helper_temp_output_buffer_setup (Lisp_Object x); Lisp_Object helper_unbind_n (int val); -bool helper_PSEUDOVECTOR_TYPEP (const union vectorlike_header *a, - enum pvec_type code); +bool helper_PSEUDOVECTOR_TYPEP_XUNTAG (const union vectorlike_header *a, + enum pvec_type code); Lisp_Object helper_save_window_excursion (Lisp_Object v1) @@ -2112,10 +2113,12 @@ helper_unbind_n (int val) } bool -helper_PSEUDOVECTOR_TYPEP (const union vectorlike_header *a, - enum pvec_type code) +helper_PSEUDOVECTOR_TYPEP_XUNTAG (const union vectorlike_header *a, + enum pvec_type code) { - return PSEUDOVECTOR_TYPEP (a, code); + return PSEUDOVECTOR_TYPEP (XUNTAG (a, Lisp_Vectorlike, + union vectorlike_header), + code); } #endif /* HAVE_LIBGCCJIT */ commit 4ca1857b501875fa3695ee7d42712e681c4767f4 Author: Andrea Corallo Date: Sat Jun 15 18:07:59 2019 +0200 fix intern_c_string_1 diff --git a/src/lread.c b/src/lread.c index bedb3d57cb..ca7b29f690 100644 --- a/src/lread.c +++ b/src/lread.c @@ -4178,7 +4178,7 @@ intern_c_string_1 (const char *str, ptrdiff_t len) if (!SYMBOLP (tem)) { - if NILP (Vpurify_flag) + if (NILP (Vpurify_flag)) string = make_string (str, len); else string = make_pure_c_string (str, len); commit a11dc2c8ad5f4162fbad497ce7a813d9f58837b4 Author: Andrea Corallo Date: Sat Jun 15 17:53:46 2019 +0200 better naming ocnvention diff --git a/src/comp.c b/src/comp.c index 6405df9cf7..b4774b9c33 100644 --- a/src/comp.c +++ b/src/comp.c @@ -127,7 +127,7 @@ along with GNU Emacs. If not, see . */ #define CASE_CALL_NARGS(name, nargs) \ case B##name: \ POP##nargs; \ - res = comp_emit_call (STR(F##name), comp.lisp_obj_type, nargs, args); \ + res = emit_call (STR(F##name), comp.lisp_obj_type, nargs, args); \ PUSH_LVAL (res); \ break @@ -137,7 +137,7 @@ along with GNU Emacs. If not, see . */ #define EMIT_SCRATCH_CALL_N(name, nargs) \ do { \ pop (nargs, &stack, args); \ - res = comp_emit_callN (name, nargs, args); \ + res = emit_callN (name, nargs, args); \ PUSH_LVAL (res); \ } while (0) @@ -147,7 +147,7 @@ along with GNU Emacs. If not, see . */ args[2] = gcc_jit_context_new_rvalue_from_int (comp.ctxt, \ comp.int_type, \ comparison); \ - res = comp_emit_call ("arithcompare", comp.lisp_obj_type, 3, args); \ + res = emit_call ("arithcompare", comp.lisp_obj_type, 3, args); \ PUSH_LVAL (res); \ } while (0) @@ -251,7 +251,7 @@ type_to_cast_field (gcc_jit_type *type) } static gcc_jit_function * -comp_func_declare (const char *f_name, gcc_jit_type *ret_type, +emit_func_declare (const char *f_name, gcc_jit_type *ret_type, unsigned nargs, gcc_jit_rvalue **args, enum gcc_jit_function_kind kind, bool reusable) { @@ -329,8 +329,9 @@ comp_func_declare (const char *f_name, gcc_jit_type *ret_type, return func; } +/* TODO this should return an rval */ static gcc_jit_lvalue * -comp_emit_call (const char *f_name, gcc_jit_type *ret_type, unsigned nargs, +emit_call (const char *f_name, gcc_jit_type *ret_type, unsigned nargs, gcc_jit_rvalue **args) { Lisp_Object key = make_string (f_name, strlen (f_name)); @@ -340,7 +341,7 @@ comp_emit_call (const char *f_name, gcc_jit_type *ret_type, unsigned nargs, if (i == -1) { - comp_func_declare(f_name, ret_type, nargs, args, GCC_JIT_FUNCTION_IMPORTED, + emit_func_declare(f_name, ret_type, nargs, args, GCC_JIT_FUNCTION_IMPORTED, true); i = hash_lookup (ht, key, &hash); eassert (i != -1); @@ -366,7 +367,7 @@ comp_emit_call (const char *f_name, gcc_jit_type *ret_type, unsigned nargs, /* Close current basic block emitting a conditional. */ INLINE static void -comp_emit_cond_jump (gcc_jit_rvalue *test, +emit_cond_jump (gcc_jit_rvalue *test, gcc_jit_block *then_target, gcc_jit_block *else_target) { gcc_jit_block_end_with_conditional (comp.bblock->gcc_bb, @@ -380,7 +381,7 @@ comp_emit_cond_jump (gcc_jit_rvalue *test, /* Close current basic block emitting a comparison between two rval. */ static gcc_jit_rvalue * -comp_emit_comp_jump (enum gcc_jit_comparison op, /* TODO add basick block as param */ +emit_comparison_jump (enum gcc_jit_comparison op, /* TODO add basick block as param */ gcc_jit_rvalue *a, gcc_jit_rvalue *b, gcc_jit_block *then_target, gcc_jit_block *else_target) { @@ -389,13 +390,13 @@ comp_emit_comp_jump (enum gcc_jit_comparison op, /* TODO add basick block as par op, a, b); - comp_emit_cond_jump (test, then_target, else_target); + emit_cond_jump (test, then_target, else_target); return test; } static gcc_jit_rvalue * -comp_cast (gcc_jit_type *new_type, gcc_jit_rvalue *obj) +emit_cast (gcc_jit_type *new_type, gcc_jit_rvalue *obj) { gcc_jit_field *orig_field = type_to_cast_field (gcc_jit_rvalue_get_type (obj)); @@ -419,7 +420,7 @@ comp_cast (gcc_jit_type *new_type, gcc_jit_rvalue *obj) } INLINE static gcc_jit_rvalue * -comp_rval_XLI (gcc_jit_rvalue *obj) +emit_rval_XLI (gcc_jit_rvalue *obj) { return gcc_jit_rvalue_access_field (obj, NULL, @@ -427,7 +428,7 @@ comp_rval_XLI (gcc_jit_rvalue *obj) } INLINE static gcc_jit_lvalue * -comp_lval_XLI (gcc_jit_lvalue *obj) +emit_lval_XLI (gcc_jit_lvalue *obj) { return gcc_jit_lvalue_access_field (obj, NULL, @@ -435,7 +436,7 @@ comp_lval_XLI (gcc_jit_lvalue *obj) } INLINE static gcc_jit_rvalue * -comp_rval_XLP (gcc_jit_rvalue *obj) +emit_rval_XLP (gcc_jit_rvalue *obj) { return gcc_jit_rvalue_access_field (obj, NULL, @@ -443,7 +444,7 @@ comp_rval_XLP (gcc_jit_rvalue *obj) } INLINE static gcc_jit_lvalue * -comp_lval_XLP (gcc_jit_lvalue *obj) +emit_lval_XLP (gcc_jit_lvalue *obj) { return gcc_jit_lvalue_access_field (obj, NULL, @@ -451,7 +452,7 @@ comp_lval_XLP (gcc_jit_lvalue *obj) } static gcc_jit_rvalue * -comp_TAGGEDP (gcc_jit_rvalue *obj, unsigned tag) +emit_TAGGEDP (gcc_jit_rvalue *obj, unsigned tag) { /* (! (((unsigned) (XLI (a) >> (USE_LSB_TAG ? 0 : VALBITS)) \ - (unsigned) (tag)) \ @@ -463,7 +464,7 @@ comp_TAGGEDP (gcc_jit_rvalue *obj, unsigned tag) NULL, GCC_JIT_BINARY_OP_RSHIFT, comp.long_long_type, - comp_rval_XLI (obj), + emit_rval_XLI (obj), gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.long_long_type, (USE_LSB_TAG ? 0 : VALBITS))); @@ -473,7 +474,7 @@ comp_TAGGEDP (gcc_jit_rvalue *obj, unsigned tag) NULL, GCC_JIT_BINARY_OP_MINUS, comp.unsigned_type, - comp_cast (comp.unsigned_type, sh_res), + emit_cast (comp.unsigned_type, sh_res), gcc_jit_context_new_rvalue_from_int ( comp.ctxt, comp.unsigned_type, @@ -499,19 +500,19 @@ comp_TAGGEDP (gcc_jit_rvalue *obj, unsigned tag) } static gcc_jit_rvalue * -comp_VECTORLIKEP (gcc_jit_rvalue *obj) +emit_VECTORLIKEP (gcc_jit_rvalue *obj) { - return comp_TAGGEDP(obj, Lisp_Vectorlike); + return emit_TAGGEDP(obj, Lisp_Vectorlike); } static gcc_jit_rvalue * -comp_CONSP (gcc_jit_rvalue *obj) +emit_CONSP (gcc_jit_rvalue *obj) { - return comp_TAGGEDP(obj, Lisp_Cons); + return emit_TAGGEDP(obj, Lisp_Cons); } /* static gcc_jit_rvalue * */ -/* comp_BIGNUMP (gcc_jit_rvalue *obj) */ +/* emit_BIGNUMP (gcc_jit_rvalue *obj) */ /* { */ /* } */ @@ -556,9 +557,9 @@ declare_PSEUDOVECTORP (void) comp.bblock = &bblock; comp.func = comp.pseudovectorp; - comp_emit_cond_jump ( - comp_cast (comp.bool_type, - comp_VECTORLIKEP (gcc_jit_param_as_rvalue (param[0]))), + emit_cond_jump ( + emit_cast (comp.bool_type, + emit_VECTORLIKEP (gcc_jit_param_as_rvalue (param[0]))), call_pseudovector_typep_b, ret_false_b); @@ -574,17 +575,18 @@ declare_PSEUDOVECTORP (void) { gcc_jit_param_as_rvalue (param[0]), gcc_jit_param_as_rvalue (param[1]) }; comp.bblock->gcc_bb = call_pseudovector_typep_b; + /* FIXME XUNTAG missing here. */ gcc_jit_block_end_with_return (call_pseudovector_typep_b, NULL, gcc_jit_lvalue_as_rvalue( - comp_emit_call ("helper_PSEUDOVECTOR_TYPEP", - comp.bool_type, - 2, - args))); + emit_call ("helper_PSEUDOVECTOR_TYPEP", + comp.bool_type, + 2, + args))); } static gcc_jit_rvalue * -comp_FIXNUMP (gcc_jit_rvalue *obj) +emit_FIXNUMP (gcc_jit_rvalue *obj) { /* (! (((unsigned) (XLI (x) >> (USE_LSB_TAG ? 0 : FIXNUM_BITS)) - (unsigned) (Lisp_Int0 >> !USE_LSB_TAG)) @@ -596,7 +598,7 @@ comp_FIXNUMP (gcc_jit_rvalue *obj) NULL, GCC_JIT_BINARY_OP_RSHIFT, comp.long_long_type, - comp_rval_XLI (obj), + emit_rval_XLI (obj), gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.long_long_type, (USE_LSB_TAG ? 0 : FIXNUM_BITS))); @@ -606,7 +608,7 @@ comp_FIXNUMP (gcc_jit_rvalue *obj) NULL, GCC_JIT_BINARY_OP_MINUS, comp.unsigned_type, - comp_cast (comp.unsigned_type, sh_res), + emit_cast (comp.unsigned_type, sh_res), gcc_jit_context_new_rvalue_from_int ( comp.ctxt, comp.unsigned_type, @@ -632,18 +634,18 @@ comp_FIXNUMP (gcc_jit_rvalue *obj) } static gcc_jit_rvalue * -comp_XFIXNUM (gcc_jit_rvalue *obj) +emit_XFIXNUM (gcc_jit_rvalue *obj) { return gcc_jit_context_new_binary_op (comp.ctxt, NULL, GCC_JIT_BINARY_OP_RSHIFT, comp.long_long_type, - comp_rval_XLI (obj), + emit_rval_XLI (obj), comp.inttypebits); } static gcc_jit_rvalue * -comp_make_fixnum (gcc_jit_block *block, gcc_jit_rvalue *obj) +emit_make_fixnum (gcc_jit_block *block, gcc_jit_rvalue *obj) { gcc_jit_rvalue *tmp = gcc_jit_context_new_binary_op (comp.ctxt, @@ -667,7 +669,7 @@ comp_make_fixnum (gcc_jit_block *block, gcc_jit_rvalue *obj) gcc_jit_block_add_assignment (block, NULL, - comp_lval_XLI (res), + emit_lval_XLI (res), tmp); return gcc_jit_lvalue_as_rvalue (res); @@ -676,7 +678,7 @@ comp_make_fixnum (gcc_jit_block *block, gcc_jit_rvalue *obj) /* Construct fill and return a lisp object form a raw pointer. */ static gcc_jit_rvalue * -comp_lisp_obj_from_ptr (basic_block_t *bblock, void *p) +emit_lisp_obj_from_ptr (basic_block_t *bblock, void *p) { static unsigned i; char ptr_var_name[40]; @@ -697,13 +699,13 @@ comp_lisp_obj_from_ptr (basic_block_t *bblock, void *p) gcc_jit_block_add_assignment (bblock->gcc_bb, NULL, - comp_lval_XLP (lisp_obj), + emit_lval_XLP (lisp_obj), void_ptr); return gcc_jit_lvalue_as_rvalue (lisp_obj); } static gcc_jit_lvalue * -comp_emit_callN (const char *f_name, unsigned nargs, gcc_jit_rvalue **args) +emit_callN (const char *f_name, unsigned nargs, gcc_jit_rvalue **args) { /* Here we set all the pointers into the scratch call area. */ /* TODO: distinguish primitives for faster calling convention. */ @@ -749,7 +751,7 @@ comp_emit_callN (const char *f_name, unsigned nargs, gcc_jit_rvalue **args) nargs); args[1] = comp.scratch; - return comp_emit_call (f_name, comp.lisp_obj_type, 2, args); + return emit_call (f_name, comp.lisp_obj_type, 2, args); } static int @@ -1067,7 +1069,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, /* Current function being compiled. */ - comp.func = comp_func_declare (f_name, comp.lisp_obj_type, comp_res.max_args, + comp.func = emit_func_declare (f_name, comp.lisp_obj_type, comp_res.max_args, NULL, GCC_JIT_FUNCTION_EXPORTED, false); char local_name[256]; @@ -1089,7 +1091,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, PUSH_PARAM (gcc_jit_function_get_param (comp.func, i)); gcc_jit_block_end_with_jump (prologue_bb, NULL, bb_map[0].gcc_bb); - gcc_jit_rvalue *nil = comp_lisp_obj_from_ptr (&bb_map[0], Qnil); + gcc_jit_rvalue *nil = emit_lisp_obj_from_ptr (&bb_map[0], Qnil); comp.bblock = NULL; @@ -1145,8 +1147,8 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, op = FETCH; varref: { - args[0] = comp_lisp_obj_from_ptr (comp.bblock, vectorp[op]); - res = comp_emit_call ("Fsymbol_value", comp.lisp_obj_type, 1, args); + args[0] = emit_lisp_obj_from_ptr (comp.bblock, vectorp[op]); + res = emit_call ("Fsymbol_value", comp.lisp_obj_type, 1, args); PUSH_LVAL (res); break; } @@ -1170,12 +1172,12 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, { POP1; args[1] = args[0]; - args[0] = comp_lisp_obj_from_ptr (comp.bblock, vectorp[op]); + args[0] = emit_lisp_obj_from_ptr (comp.bblock, vectorp[op]); args[2] = nil; args[3] = gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.int_type, SET_INTERNAL_SET); - res = comp_emit_call ("set_internal", comp.lisp_obj_type, 4, args); + res = emit_call ("set_internal", comp.lisp_obj_type, 4, args); PUSH_LVAL (res); } break; @@ -1197,9 +1199,9 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, op -= Bvarbind; varbind: { - args[0] = comp_lisp_obj_from_ptr (comp.bblock, vectorp[op]); + args[0] = emit_lisp_obj_from_ptr (comp.bblock, vectorp[op]); pop (1, &stack, &args[1]); - res = comp_emit_call ("specbind", comp.lisp_obj_type, 2, args); + res = emit_call ("specbind", comp.lisp_obj_type, 2, args); PUSH_LVAL (res); break; } @@ -1223,7 +1225,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, { ptrdiff_t nargs = op + 1; pop (nargs, &stack, args); - res = comp_emit_callN ("Ffuncall", nargs, args); + res = emit_callN ("Ffuncall", nargs, args); PUSH_LVAL (res); break; } @@ -1249,7 +1251,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, comp.ptrdiff_type, op); - comp_emit_call ("helper_unbind_n", comp.lisp_obj_type, 1, args); + emit_call ("helper_unbind_n", comp.lisp_obj_type, 1, args); } break; case Bpophandler: @@ -1270,7 +1272,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, comp.bblock->gcc_bb, NULL, TOS, - comp_CONSP(gcc_jit_lvalue_as_rvalue (TOS))); + emit_CONSP(gcc_jit_lvalue_as_rvalue (TOS))); break; CASE_CALL_NARGS (stringp, 1); @@ -1295,12 +1297,12 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, { POP1; args[1] = nil; - res = comp_emit_call ("Fcons", comp.lisp_obj_type, 2, args); + res = emit_call ("Fcons", comp.lisp_obj_type, 2, args); PUSH_LVAL (res); for (int i = 0; i < op; ++i) { POP2; - res = comp_emit_call ("Fcons", comp.lisp_obj_type, 2, args); + res = emit_call ("Fcons", comp.lisp_obj_type, 2, args); PUSH_LVAL (res); } break; @@ -1343,16 +1345,16 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, gcc_jit_function_new_block (comp.func, "fcall_sub1"); gcc_jit_rvalue *tos_as_num = - comp_XFIXNUM (gcc_jit_lvalue_as_rvalue (TOS)); + emit_XFIXNUM (gcc_jit_lvalue_as_rvalue (TOS)); - comp_emit_cond_jump ( + emit_cond_jump ( gcc_jit_context_new_binary_op ( comp.ctxt, NULL, GCC_JIT_BINARY_OP_LOGICAL_AND, comp.bool_type, - comp_cast (comp.bool_type, - comp_FIXNUMP (gcc_jit_lvalue_as_rvalue (TOS))), + emit_cast (comp.bool_type, + emit_FIXNUMP (gcc_jit_lvalue_as_rvalue (TOS))), gcc_jit_context_new_comparison (comp.ctxt, NULL, GCC_JIT_COMPARISON_NE, @@ -1372,13 +1374,13 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, gcc_jit_block_add_assignment (sub1_inline_block, NULL, TOS, - comp_make_fixnum (sub1_inline_block, + emit_make_fixnum (sub1_inline_block, sub1_inline_res)); basic_block_t bb_orig = *comp.bblock; comp.bblock->gcc_bb = sub1_fcall_block; POP1; - res = comp_emit_call ("Fsub1", comp.lisp_obj_type, 1, args); + res = emit_call ("Fsub1", comp.lisp_obj_type, 1, args); PUSH_LVAL (res); *comp.bblock = bb_orig; @@ -1403,16 +1405,16 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, gcc_jit_function_new_block (comp.func, "fcall_add1"); gcc_jit_rvalue *tos_as_num = - comp_XFIXNUM (gcc_jit_lvalue_as_rvalue (TOS)); + emit_XFIXNUM (gcc_jit_lvalue_as_rvalue (TOS)); - comp_emit_cond_jump ( + emit_cond_jump ( gcc_jit_context_new_binary_op ( comp.ctxt, NULL, GCC_JIT_BINARY_OP_LOGICAL_AND, comp.bool_type, - comp_cast (comp.bool_type, - comp_FIXNUMP (gcc_jit_lvalue_as_rvalue (TOS))), + emit_cast (comp.bool_type, + emit_FIXNUMP (gcc_jit_lvalue_as_rvalue (TOS))), gcc_jit_context_new_comparison (comp.ctxt, NULL, GCC_JIT_COMPARISON_NE, @@ -1432,13 +1434,13 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, gcc_jit_block_add_assignment (add1_inline_block, NULL, TOS, - comp_make_fixnum (add1_inline_block, + emit_make_fixnum (add1_inline_block, add1_inline_res)); basic_block_t bb_orig = *comp.bblock; comp.bblock->gcc_bb = add1_fcall_block; POP1; - res = comp_emit_call ("Fadd1", comp.lisp_obj_type, 1, args); + res = emit_call ("Fadd1", comp.lisp_obj_type, 1, args); PUSH_LVAL (res); *comp.bblock = bb_orig; @@ -1487,16 +1489,16 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, gcc_jit_function_new_block (comp.func, "fcall_negate"); gcc_jit_rvalue *tos_as_num = - comp_XFIXNUM (gcc_jit_lvalue_as_rvalue (TOS)); + emit_XFIXNUM (gcc_jit_lvalue_as_rvalue (TOS)); - comp_emit_cond_jump ( + emit_cond_jump ( gcc_jit_context_new_binary_op ( comp.ctxt, NULL, GCC_JIT_BINARY_OP_LOGICAL_AND, comp.bool_type, - comp_cast (comp.bool_type, - comp_FIXNUMP (gcc_jit_lvalue_as_rvalue (TOS))), + emit_cast (comp.bool_type, + emit_FIXNUMP (gcc_jit_lvalue_as_rvalue (TOS))), gcc_jit_context_new_comparison (comp.ctxt, NULL, GCC_JIT_COMPARISON_NE, @@ -1515,7 +1517,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, gcc_jit_block_add_assignment (negate_inline_block, NULL, TOS, - comp_make_fixnum (negate_inline_block, + emit_make_fixnum (negate_inline_block, negate_inline_res)); basic_block_t bb_orig = *comp.bblock; @@ -1546,10 +1548,10 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.ptrdiff_type, PT); - res = comp_emit_call ("make_fixed_natnum", - comp.lisp_obj_type, - 1, - args); + res = emit_call ("make_fixed_natnum", + comp.lisp_obj_type, + 1, + args); PUSH_LVAL (res); break; @@ -1564,10 +1566,10 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.ptrdiff_type, ZV); - res = comp_emit_call ("make_fixed_natnum", - comp.lisp_obj_type, - 1, - args); + res = emit_call ("make_fixed_natnum", + comp.lisp_obj_type, + 1, + args); PUSH_LVAL (res); break; @@ -1576,10 +1578,10 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.ptrdiff_type, BEGV); - res = comp_emit_call ("make_fixed_natnum", - comp.lisp_obj_type, - 1, - args); + res = emit_call ("make_fixed_natnum", + comp.lisp_obj_type, + 1, + args); PUSH_LVAL (res); break; @@ -1587,7 +1589,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, CASE_CALL_NARGS (following_char, 0); case Bpreceding_char: - res = comp_emit_call ("Fprevious_char", comp.lisp_obj_type, 0, args); + res = emit_call ("Fprevious_char", comp.lisp_obj_type, 0, args); PUSH_LVAL (res); break; @@ -1596,7 +1598,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, case Bindent_to: POP1; args[1] = nil; - res = comp_emit_call ("Findent_to", comp.lisp_obj_type, 2, args); + res = emit_call ("Findent_to", comp.lisp_obj_type, 2, args); PUSH_LVAL (res); break; @@ -1609,14 +1611,14 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, case Bsave_current_buffer: /* Obsolete since ??. */ case Bsave_current_buffer_1: - comp_emit_call ("record_unwind_current_buffer", - comp.void_type, 0, NULL); + emit_call ("record_unwind_current_buffer", + comp.void_type, 0, NULL); break; case Binteractive_p: /* Obsolete since 24.1. */ - PUSH_RVAL (comp_lisp_obj_from_ptr (comp.bblock, + PUSH_RVAL (emit_lisp_obj_from_ptr (comp.bblock, intern ("interactive-p"))); - res = comp_emit_call ("call0", comp.lisp_obj_type, 1, args); + res = emit_call ("call0", comp.lisp_obj_type, 1, args); PUSH_LVAL (res); break; @@ -1647,32 +1649,32 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, case Bgotoifnil: op = FETCH2; POP1; - comp_emit_comp_jump (GCC_JIT_COMPARISON_EQ, args[0], nil, - bb_map[op].gcc_bb, bb_map[pc].gcc_bb); + emit_comparison_jump (GCC_JIT_COMPARISON_EQ, args[0], nil, + bb_map[op].gcc_bb, bb_map[pc].gcc_bb); break; case Bgotoifnonnil: op = FETCH2; POP1; - comp_emit_comp_jump (GCC_JIT_COMPARISON_NE, args[0], nil, - bb_map[op].gcc_bb, bb_map[pc].gcc_bb); + emit_comparison_jump (GCC_JIT_COMPARISON_NE, args[0], nil, + bb_map[op].gcc_bb, bb_map[pc].gcc_bb); break; case Bgotoifnilelsepop: op = FETCH2; - comp_emit_comp_jump (GCC_JIT_COMPARISON_EQ, - gcc_jit_lvalue_as_rvalue (TOS), - nil, - bb_map[op].gcc_bb, bb_map[pc].gcc_bb); + emit_comparison_jump (GCC_JIT_COMPARISON_EQ, + gcc_jit_lvalue_as_rvalue (TOS), + nil, + bb_map[op].gcc_bb, bb_map[pc].gcc_bb); POP1; break; case Bgotoifnonnilelsepop: op = FETCH2; - comp_emit_comp_jump (GCC_JIT_COMPARISON_NE, - gcc_jit_lvalue_as_rvalue (TOS), - nil, - bb_map[op].gcc_bb, bb_map[pc].gcc_bb); + emit_comparison_jump (GCC_JIT_COMPARISON_NE, + gcc_jit_lvalue_as_rvalue (TOS), + nil, + bb_map[op].gcc_bb, bb_map[pc].gcc_bb); POP1; break; @@ -1693,59 +1695,59 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, break; case Bsave_excursion: - res = comp_emit_call ("record_unwind_protect_excursion", + res = emit_call ("record_unwind_protect_excursion", comp.void_type, 0, args); break; case Bsave_window_excursion: /* Obsolete since 24.1. */ POP1; - res = comp_emit_call ("helper_save_window_excursion", - comp.lisp_obj_type, 1, args); + res = emit_call ("helper_save_window_excursion", + comp.lisp_obj_type, 1, args); PUSH_LVAL (res); break; case Bsave_restriction: - args[0] = comp_lisp_obj_from_ptr (comp.bblock, + args[0] = emit_lisp_obj_from_ptr (comp.bblock, save_restriction_restore); args[1] = - gcc_jit_lvalue_as_rvalue (comp_emit_call ("save_restriction_save", - comp.lisp_obj_type, - 0, - NULL)); - comp_emit_call ("record_unwind_protect", comp.void_ptr_type, 2, args); + gcc_jit_lvalue_as_rvalue (emit_call ("save_restriction_save", + comp.lisp_obj_type, + 0, + NULL)); + emit_call ("record_unwind_protect", comp.void_ptr_type, 2, args); break; case Bcatch: /* Obsolete since 24.4. */ POP2; args[2] = args[1]; - args[1] = comp_lisp_obj_from_ptr (comp.bblock, eval_sub); - comp_emit_call ("internal_catch", comp.void_ptr_type, 3, args); + args[1] = emit_lisp_obj_from_ptr (comp.bblock, eval_sub); + emit_call ("internal_catch", comp.void_ptr_type, 3, args); break; case Bunwind_protect: /* FIXME: avoid closure for lexbind. */ POP1; - comp_emit_call ("helper_unwind_protect", comp.void_type, 1, args); + emit_call ("helper_unwind_protect", comp.void_type, 1, args); break; case Bcondition_case: /* Obsolete since 24.4. */ POP3; - comp_emit_call ("internal_lisp_condition_case", - comp.lisp_obj_type, 3, args); + emit_call ("internal_lisp_condition_case", + comp.lisp_obj_type, 3, args); break; case Btemp_output_buffer_setup: /* Obsolete since 24.1. */ POP1; - res = comp_emit_call ("helper_temp_output_buffer_setup", comp.lisp_obj_type, - 1, args); + res = emit_call ("helper_temp_output_buffer_setup", comp.lisp_obj_type, + 1, args); PUSH_LVAL (res); break; case Btemp_output_buffer_show: /* Obsolete since 24.1. */ POP2; - comp_emit_call ("temp_output_buffer_show", comp.void_type, 1, - &args[1]); + emit_call ("temp_output_buffer_show", comp.void_type, 1, + &args[1]); PUSH_RVAL (args[0]); - comp_emit_call ("helper_unbind_n", comp.lisp_obj_type, 1, args); + emit_call ("helper_unbind_n", comp.lisp_obj_type, 1, args); break; case Bunbind_all: /* Obsolete. Never used. */ @@ -1762,13 +1764,13 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, case Bstringeqlsign: POP2; - res = comp_emit_call ("Fstring_equal", comp.lisp_obj_type, 2, args); + res = emit_call ("Fstring_equal", comp.lisp_obj_type, 2, args); PUSH_LVAL (res); break; case Bstringlss: POP2; - res = comp_emit_call ("Fstring_lessp", comp.lisp_obj_type, 2, args); + res = emit_call ("Fstring_lessp", comp.lisp_obj_type, 2, args); PUSH_LVAL (res); break; @@ -1818,35 +1820,35 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, op = FETCH - 128; op += pc; POP1; - comp_emit_comp_jump (GCC_JIT_COMPARISON_EQ, args[0], nil, - bb_map[op].gcc_bb, bb_map[pc].gcc_bb); + emit_comparison_jump (GCC_JIT_COMPARISON_EQ, args[0], nil, + bb_map[op].gcc_bb, bb_map[pc].gcc_bb); break; case BRgotoifnonnil: op = FETCH - 128; op += pc; POP1; - comp_emit_comp_jump (GCC_JIT_COMPARISON_NE, args[0], nil, - bb_map[op].gcc_bb, bb_map[pc].gcc_bb); + emit_comparison_jump (GCC_JIT_COMPARISON_NE, args[0], nil, + bb_map[op].gcc_bb, bb_map[pc].gcc_bb); break; case BRgotoifnilelsepop: op = FETCH - 128; op += pc; - comp_emit_comp_jump (GCC_JIT_COMPARISON_EQ, - gcc_jit_lvalue_as_rvalue (TOS), - nil, - bb_map[op].gcc_bb, bb_map[pc].gcc_bb); + emit_comparison_jump (GCC_JIT_COMPARISON_EQ, + gcc_jit_lvalue_as_rvalue (TOS), + nil, + bb_map[op].gcc_bb, bb_map[pc].gcc_bb); POP1; break; case BRgotoifnonnilelsepop: op = FETCH - 128; op += pc; - comp_emit_comp_jump (GCC_JIT_COMPARISON_NE, - gcc_jit_lvalue_as_rvalue (TOS), - nil, - bb_map[op].gcc_bb, bb_map[pc].gcc_bb); + emit_comparison_jump (GCC_JIT_COMPARISON_NE, + gcc_jit_lvalue_as_rvalue (TOS), + nil, + bb_map[op].gcc_bb, bb_map[pc].gcc_bb); POP1; break; @@ -1893,7 +1895,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, if (pc >= bytestr_length || bytestr_data[pc] != Bswitch) { gcc_jit_rvalue *c = - comp_lisp_obj_from_ptr (comp.bblock, vectorp[op]); + emit_lisp_obj_from_ptr (comp.bblock, vectorp[op]); PUSH_RVAL (c); break; } commit 8f446c06498b0c41e58d9265aa72c4615a220956 Author: Andrea Corallo Date: Sat Jun 15 17:40:14 2019 +0200 add declare_PSEUDOVECTORP diff --git a/src/comp.c b/src/comp.c index 5ae4e1b053..6405df9cf7 100644 --- a/src/comp.c +++ b/src/comp.c @@ -186,6 +186,7 @@ typedef struct { gcc_jit_rvalue *one; gcc_jit_rvalue *inttypebits; gcc_jit_rvalue *lisp_int0; + gcc_jit_function *pseudovectorp; basic_block_t *bblock; /* Current basic block */ Lisp_Object func_hash; /* f_name -> gcc_func */ } comp_t; @@ -249,6 +250,150 @@ type_to_cast_field (gcc_jit_type *type) return field; } +static gcc_jit_function * +comp_func_declare (const char *f_name, gcc_jit_type *ret_type, + unsigned nargs, gcc_jit_rvalue **args, + enum gcc_jit_function_kind kind, bool reusable) +{ + gcc_jit_param *param[4]; + gcc_jit_type *type[4]; + + /* If args are passed types are extracted from that otherwise assume params */ + /* are all lisp objs. */ + if (args) + for (int i = 0; i < nargs; i++) + type[i] = gcc_jit_rvalue_get_type (args[i]); + else + for (int i = 0; i < nargs; i++) + type[i] = comp.lisp_obj_type; + + switch (nargs) { + case 4: + param[3] = gcc_jit_context_new_param(comp.ctxt, + NULL, + type[3], + "c"); + /* Fall through */ + FALLTHROUGH; + case 3: + param[2] = gcc_jit_context_new_param(comp.ctxt, + NULL, + type[2], + "c"); + /* Fall through */ + FALLTHROUGH; + case 2: + param[1] = gcc_jit_context_new_param(comp.ctxt, + NULL, + type[1], + "b"); + /* Fall through */ + FALLTHROUGH; + case 1: + param[0] = gcc_jit_context_new_param(comp.ctxt, + NULL, + type[0], + "a"); + /* Fall through */ + FALLTHROUGH; + case 0: + break; + default: + /* Argnum not supported */ + eassert (0); + } + + gcc_jit_function *func = + gcc_jit_context_new_function(comp.ctxt, NULL, + kind, + ret_type, + f_name, + nargs, + param, + 0); + + if (reusable) + { + Lisp_Object value; + Lisp_Object key = make_string (f_name, strlen (f_name)); + value = make_pointer_integer (XPL (func)); + + EMACS_UINT hash = 0; + struct Lisp_Hash_Table *ht = XHASH_TABLE (comp.func_hash); + ptrdiff_t i = hash_lookup (ht, key, &hash); + /* Don't want to declare the same function two times */ + eassert (i == -1); + hash_put (ht, key, value, hash); + } + + return func; +} + +static gcc_jit_lvalue * +comp_emit_call (const char *f_name, gcc_jit_type *ret_type, unsigned nargs, + gcc_jit_rvalue **args) +{ + Lisp_Object key = make_string (f_name, strlen (f_name)); + EMACS_UINT hash = 0; + struct Lisp_Hash_Table *ht = XHASH_TABLE (comp.func_hash); + ptrdiff_t i = hash_lookup (ht, key, &hash); + + if (i == -1) + { + comp_func_declare(f_name, ret_type, nargs, args, GCC_JIT_FUNCTION_IMPORTED, + true); + i = hash_lookup (ht, key, &hash); + eassert (i != -1); + } + + Lisp_Object value = HASH_VALUE (ht, hash_lookup (ht, key, &hash)); + gcc_jit_function *func = (gcc_jit_function *) XFIXNUMPTR (value); + + gcc_jit_lvalue *res = gcc_jit_function_new_local(comp.func, + NULL, + ret_type, + "res"); + gcc_jit_block_add_assignment(comp.bblock->gcc_bb, NULL, + res, + gcc_jit_context_new_call(comp.ctxt, + NULL, + func, + nargs, + args)); + return res; +} + +/* Close current basic block emitting a conditional. */ + +INLINE static void +comp_emit_cond_jump (gcc_jit_rvalue *test, + gcc_jit_block *then_target, gcc_jit_block *else_target) +{ + gcc_jit_block_end_with_conditional (comp.bblock->gcc_bb, + NULL, + test, + then_target, + else_target); + comp.bblock->terminated = true; +} + +/* Close current basic block emitting a comparison between two rval. */ + +static gcc_jit_rvalue * +comp_emit_comp_jump (enum gcc_jit_comparison op, /* TODO add basick block as param */ + gcc_jit_rvalue *a, gcc_jit_rvalue *b, + gcc_jit_block *then_target, gcc_jit_block *else_target) +{ + gcc_jit_rvalue *test = gcc_jit_context_new_comparison (comp.ctxt, + NULL, + op, + a, b); + + comp_emit_cond_jump (test, then_target, else_target); + + return test; +} + static gcc_jit_rvalue * comp_cast (gcc_jit_type *new_type, gcc_jit_rvalue *obj) { @@ -365,6 +510,79 @@ comp_CONSP (gcc_jit_rvalue *obj) return comp_TAGGEDP(obj, Lisp_Cons); } +/* static gcc_jit_rvalue * */ +/* comp_BIGNUMP (gcc_jit_rvalue *obj) */ +/* { */ + +/* } */ + + +/* Declare a substitute for PSEUDOVECTORP as inline function. */ + +static void +declare_PSEUDOVECTORP (void) +{ + gcc_jit_param *param[2] = + { gcc_jit_context_new_param (comp.ctxt, + NULL, + comp.lisp_obj_type, + "a"), + gcc_jit_context_new_param (comp.ctxt, + NULL, + comp.int_type, + "code") }; + + comp.pseudovectorp = + gcc_jit_context_new_function (comp.ctxt, NULL, + GCC_JIT_FUNCTION_ALWAYS_INLINE, + comp.bool_type, + "PSEUDOVECTORP", + 2, + param, + 0); + + gcc_jit_block *initial_block = + gcc_jit_function_new_block (comp.pseudovectorp, "PSEUDOVECTORP_initial_block"); + + gcc_jit_block *ret_false_b = + gcc_jit_function_new_block (comp.pseudovectorp, "ret_false"); + + gcc_jit_block *call_pseudovector_typep_b = + gcc_jit_function_new_block (comp.pseudovectorp, "call_pseudovector"); + + /* Set current context as needed */ + basic_block_t bblock = { .gcc_bb = initial_block, + .terminated = false }; + comp.bblock = &bblock; + comp.func = comp.pseudovectorp; + + comp_emit_cond_jump ( + comp_cast (comp.bool_type, + comp_VECTORLIKEP (gcc_jit_param_as_rvalue (param[0]))), + call_pseudovector_typep_b, + ret_false_b); + + comp.bblock->gcc_bb = ret_false_b; + gcc_jit_block_end_with_return (ret_false_b, + NULL, + gcc_jit_context_new_rvalue_from_int( + comp.ctxt, + comp.bool_type, + false)); + + gcc_jit_rvalue *args[2] = + { gcc_jit_param_as_rvalue (param[0]), + gcc_jit_param_as_rvalue (param[1]) }; + comp.bblock->gcc_bb = call_pseudovector_typep_b; + gcc_jit_block_end_with_return (call_pseudovector_typep_b, + NULL, + gcc_jit_lvalue_as_rvalue( + comp_emit_call ("helper_PSEUDOVECTOR_TYPEP", + comp.bool_type, + 2, + args))); +} + static gcc_jit_rvalue * comp_FIXNUMP (gcc_jit_rvalue *obj) { @@ -484,119 +702,6 @@ comp_lisp_obj_from_ptr (basic_block_t *bblock, void *p) return gcc_jit_lvalue_as_rvalue (lisp_obj); } -static gcc_jit_function * -comp_func_declare (const char *f_name, gcc_jit_type *ret_type, - unsigned nargs, gcc_jit_rvalue **args, - enum gcc_jit_function_kind kind, bool reusable) -{ - gcc_jit_param *param[4]; - gcc_jit_type *type[4]; - - /* If args are passed types are extracted from that otherwise assume params */ - /* are all lisp objs. */ - if (args) - for (int i = 0; i < nargs; i++) - type[i] = gcc_jit_rvalue_get_type (args[i]); - else - for (int i = 0; i < nargs; i++) - type[i] = comp.lisp_obj_type; - - switch (nargs) { - case 4: - param[3] = gcc_jit_context_new_param(comp.ctxt, - NULL, - type[3], - "c"); - /* Fall through */ - FALLTHROUGH; - case 3: - param[2] = gcc_jit_context_new_param(comp.ctxt, - NULL, - type[2], - "c"); - /* Fall through */ - FALLTHROUGH; - case 2: - param[1] = gcc_jit_context_new_param(comp.ctxt, - NULL, - type[1], - "b"); - /* Fall through */ - FALLTHROUGH; - case 1: - param[0] = gcc_jit_context_new_param(comp.ctxt, - NULL, - type[0], - "a"); - /* Fall through */ - FALLTHROUGH; - case 0: - break; - default: - /* Argnum not supported */ - eassert (0); - } - - gcc_jit_function *func = - gcc_jit_context_new_function(comp.ctxt, NULL, - kind, - comp.lisp_obj_type, - f_name, - nargs, - param, - 0); - - if (reusable) - { - Lisp_Object value; - Lisp_Object key = make_string (f_name, strlen (f_name)); - value = make_pointer_integer (XPL (func)); - - EMACS_UINT hash = 0; - struct Lisp_Hash_Table *ht = XHASH_TABLE (comp.func_hash); - ptrdiff_t i = hash_lookup (ht, key, &hash); - /* Don't want to declare the same function two times */ - eassert (i == -1); - hash_put (ht, key, value, hash); - } - - return func; -} - -static gcc_jit_lvalue * -comp_emit_call (const char *f_name, gcc_jit_type *ret_type, unsigned nargs, - gcc_jit_rvalue **args) -{ - Lisp_Object key = make_string (f_name, strlen (f_name)); - EMACS_UINT hash = 0; - struct Lisp_Hash_Table *ht = XHASH_TABLE (comp.func_hash); - ptrdiff_t i = hash_lookup (ht, key, &hash); - - if (i == -1) - { - comp_func_declare(f_name, ret_type, nargs, args, GCC_JIT_FUNCTION_IMPORTED, - true); - i = hash_lookup (ht, key, &hash); - eassert (i != -1); - } - - Lisp_Object value = HASH_VALUE (ht, hash_lookup (ht, key, &hash)); - gcc_jit_function *func = (gcc_jit_function *) XFIXNUMPTR (value); - - gcc_jit_lvalue *res = gcc_jit_function_new_local(comp.func, - NULL, - ret_type, - "res"); - gcc_jit_block_add_assignment(comp.bblock->gcc_bb, NULL, - res, - gcc_jit_context_new_call(comp.ctxt, - NULL, - func, - nargs, - args)); - return res; -} - static gcc_jit_lvalue * comp_emit_callN (const char *f_name, unsigned nargs, gcc_jit_rvalue **args) { @@ -762,37 +867,6 @@ compute_bblocks (ptrdiff_t bytestr_length, unsigned char *bytestr_data) return bb_map; } -/* Close current basic block emitting a conditional. */ - -INLINE static void -comp_emit_cond_jump (gcc_jit_rvalue *test, - gcc_jit_block *then_target, gcc_jit_block *else_target) -{ - gcc_jit_block_end_with_conditional (comp.bblock->gcc_bb, - NULL, - test, - then_target, - else_target); - comp.bblock->terminated = true; -} - -/* Close current basic block emitting a comparison between two rval. */ - -static gcc_jit_rvalue * -comp_emit_comp_jump (enum gcc_jit_comparison op, - gcc_jit_rvalue *a, gcc_jit_rvalue *b, - gcc_jit_block *then_target, gcc_jit_block *else_target) -{ - gcc_jit_rvalue *test = gcc_jit_context_new_comparison (comp.ctxt, - NULL, - op, - a, b); - - comp_emit_cond_jump (test, then_target, else_target); - - return test; -} - static void init_comp (int opt_level) { @@ -937,6 +1011,8 @@ init_comp (int opt_level) NULL); comp.func_hash = CALLN (Fmake_hash_table, QCtest, Qequal, QCweakness, Qt); + + declare_PSEUDOVECTORP (); } static void @@ -1998,6 +2074,9 @@ Lisp_Object helper_temp_output_buffer_setup (Lisp_Object x); Lisp_Object helper_unbind_n (int val); +bool helper_PSEUDOVECTOR_TYPEP (const union vectorlike_header *a, + enum pvec_type code); + Lisp_Object helper_save_window_excursion (Lisp_Object v1) { @@ -2030,4 +2109,11 @@ helper_unbind_n (int val) return unbind_to (SPECPDL_INDEX () - val, Qnil); } +bool +helper_PSEUDOVECTOR_TYPEP (const union vectorlike_header *a, + enum pvec_type code) +{ + return PSEUDOVECTOR_TYPEP (a, code); +} + #endif /* HAVE_LIBGCCJIT */ commit 79dc3a717e23cf66d04cf3ec3392bd7635839bd0 Author: Andrea Corallo Date: Thu Jun 13 21:18:25 2019 +0200 XLP XLI l and r values diff --git a/src/comp.c b/src/comp.c index 3f938e2c5d..5ae4e1b053 100644 --- a/src/comp.c +++ b/src/comp.c @@ -274,13 +274,37 @@ comp_cast (gcc_jit_type *new_type, gcc_jit_rvalue *obj) } INLINE static gcc_jit_rvalue * -comp_XLI (gcc_jit_rvalue *obj) +comp_rval_XLI (gcc_jit_rvalue *obj) { return gcc_jit_rvalue_access_field (obj, NULL, comp.lisp_obj_as_num); } +INLINE static gcc_jit_lvalue * +comp_lval_XLI (gcc_jit_lvalue *obj) +{ + return gcc_jit_lvalue_access_field (obj, + NULL, + comp.lisp_obj_as_num); +} + +INLINE static gcc_jit_rvalue * +comp_rval_XLP (gcc_jit_rvalue *obj) +{ + return gcc_jit_rvalue_access_field (obj, + NULL, + comp.lisp_obj_as_ptr); +} + +INLINE static gcc_jit_lvalue * +comp_lval_XLP (gcc_jit_lvalue *obj) +{ + return gcc_jit_lvalue_access_field (obj, + NULL, + comp.lisp_obj_as_ptr); +} + static gcc_jit_rvalue * comp_TAGGEDP (gcc_jit_rvalue *obj, unsigned tag) { @@ -294,7 +318,7 @@ comp_TAGGEDP (gcc_jit_rvalue *obj, unsigned tag) NULL, GCC_JIT_BINARY_OP_RSHIFT, comp.long_long_type, - comp_XLI (obj), + comp_rval_XLI (obj), gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.long_long_type, (USE_LSB_TAG ? 0 : VALBITS))); @@ -354,7 +378,7 @@ comp_FIXNUMP (gcc_jit_rvalue *obj) NULL, GCC_JIT_BINARY_OP_RSHIFT, comp.long_long_type, - comp_XLI (obj), + comp_rval_XLI (obj), gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.long_long_type, (USE_LSB_TAG ? 0 : FIXNUM_BITS))); @@ -396,7 +420,7 @@ comp_XFIXNUM (gcc_jit_rvalue *obj) NULL, GCC_JIT_BINARY_OP_RSHIFT, comp.long_long_type, - comp_XLI (obj), + comp_rval_XLI (obj), comp.inttypebits); } @@ -425,10 +449,7 @@ comp_make_fixnum (gcc_jit_block *block, gcc_jit_rvalue *obj) gcc_jit_block_add_assignment (block, NULL, - gcc_jit_lvalue_access_field ( - res, - NULL, - comp.lisp_obj_as_num), + comp_lval_XLI (res), tmp); return gcc_jit_lvalue_as_rvalue (res); @@ -451,11 +472,6 @@ comp_lisp_obj_from_ptr (basic_block_t *bblock, void *p) NULL, comp.lisp_obj_type, ptr_var_name); - gcc_jit_lvalue *lisp_obj_as_ptr = - gcc_jit_lvalue_access_field (lisp_obj, - NULL, - comp.lisp_obj_as_ptr); - gcc_jit_rvalue *void_ptr = gcc_jit_context_new_rvalue_from_ptr(comp.ctxt, comp.void_ptr_type, @@ -463,7 +479,7 @@ comp_lisp_obj_from_ptr (basic_block_t *bblock, void *p) gcc_jit_block_add_assignment (bblock->gcc_bb, NULL, - lisp_obj_as_ptr, + comp_lval_XLP (lisp_obj), void_ptr); return gcc_jit_lvalue_as_rvalue (lisp_obj); } commit 187c1eed6f5e21088c5b9b129c65b3e2fe512d1b Author: Andrea Corallo Date: Thu Jun 13 21:07:30 2019 +0200 rename comp_lisp_obj_from_ptr diff --git a/src/comp.c b/src/comp.c index 7522e726d1..3f938e2c5d 100644 --- a/src/comp.c +++ b/src/comp.c @@ -437,7 +437,7 @@ comp_make_fixnum (gcc_jit_block *block, gcc_jit_rvalue *obj) /* Construct fill and return a lisp object form a raw pointer. */ static gcc_jit_rvalue * -comp_lisp_obj_as_ptr_from_ptr (basic_block_t *bblock, void *p) +comp_lisp_obj_from_ptr (basic_block_t *bblock, void *p) { static unsigned i; char ptr_var_name[40]; @@ -997,7 +997,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, PUSH_PARAM (gcc_jit_function_get_param (comp.func, i)); gcc_jit_block_end_with_jump (prologue_bb, NULL, bb_map[0].gcc_bb); - gcc_jit_rvalue *nil = comp_lisp_obj_as_ptr_from_ptr (&bb_map[0], Qnil); + gcc_jit_rvalue *nil = comp_lisp_obj_from_ptr (&bb_map[0], Qnil); comp.bblock = NULL; @@ -1053,7 +1053,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, op = FETCH; varref: { - args[0] = comp_lisp_obj_as_ptr_from_ptr (comp.bblock, vectorp[op]); + args[0] = comp_lisp_obj_from_ptr (comp.bblock, vectorp[op]); res = comp_emit_call ("Fsymbol_value", comp.lisp_obj_type, 1, args); PUSH_LVAL (res); break; @@ -1078,7 +1078,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, { POP1; args[1] = args[0]; - args[0] = comp_lisp_obj_as_ptr_from_ptr (comp.bblock, vectorp[op]); + args[0] = comp_lisp_obj_from_ptr (comp.bblock, vectorp[op]); args[2] = nil; args[3] = gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.int_type, @@ -1105,7 +1105,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, op -= Bvarbind; varbind: { - args[0] = comp_lisp_obj_as_ptr_from_ptr (comp.bblock, vectorp[op]); + args[0] = comp_lisp_obj_from_ptr (comp.bblock, vectorp[op]); pop (1, &stack, &args[1]); res = comp_emit_call ("specbind", comp.lisp_obj_type, 2, args); PUSH_LVAL (res); @@ -1522,8 +1522,8 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, break; case Binteractive_p: /* Obsolete since 24.1. */ - PUSH_RVAL (comp_lisp_obj_as_ptr_from_ptr (comp.bblock, - intern ("interactive-p"))); + PUSH_RVAL (comp_lisp_obj_from_ptr (comp.bblock, + intern ("interactive-p"))); res = comp_emit_call ("call0", comp.lisp_obj_type, 1, args); PUSH_LVAL (res); break; @@ -1613,8 +1613,8 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, break; case Bsave_restriction: - args[0] = comp_lisp_obj_as_ptr_from_ptr (comp.bblock, - save_restriction_restore); + args[0] = comp_lisp_obj_from_ptr (comp.bblock, + save_restriction_restore); args[1] = gcc_jit_lvalue_as_rvalue (comp_emit_call ("save_restriction_save", comp.lisp_obj_type, @@ -1626,7 +1626,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, case Bcatch: /* Obsolete since 24.4. */ POP2; args[2] = args[1]; - args[1] = comp_lisp_obj_as_ptr_from_ptr (comp.bblock, eval_sub); + args[1] = comp_lisp_obj_from_ptr (comp.bblock, eval_sub); comp_emit_call ("internal_catch", comp.void_ptr_type, 3, args); break; @@ -1801,7 +1801,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, if (pc >= bytestr_length || bytestr_data[pc] != Bswitch) { gcc_jit_rvalue *c = - comp_lisp_obj_as_ptr_from_ptr (comp.bblock, vectorp[op]); + comp_lisp_obj_from_ptr (comp.bblock, vectorp[op]); PUSH_RVAL (c); break; } commit d88694315f88baa24d4e0bd40be450218088292b Author: Andrea Corallo Date: Thu Jun 13 20:56:44 2019 +0200 reset compiler context for everi run diff --git a/src/comp.c b/src/comp.c index 79aa0bdc03..7522e726d1 100644 --- a/src/comp.c +++ b/src/comp.c @@ -777,6 +777,162 @@ comp_emit_comp_jump (enum gcc_jit_comparison op, return test; } +static void +init_comp (int opt_level) +{ + comp.ctxt = gcc_jit_context_acquire(); + + if (COMP_DEBUG) + { + logfile = fopen ("libgccjit.log", "w"); + gcc_jit_context_set_logfile (comp.ctxt, + logfile, + 0, 0); + gcc_jit_context_set_bool_option (comp.ctxt, + GCC_JIT_BOOL_OPTION_DUMP_EVERYTHING, + 1); + gcc_jit_context_set_bool_option (comp.ctxt, + GCC_JIT_BOOL_OPTION_KEEP_INTERMEDIATES, + 1); + } + if (COMP_DEBUG > 1) + { + gcc_jit_context_dump_reproducer_to_file (comp.ctxt, "comp_reproducer.c"); + gcc_jit_context_dump_to_file (comp.ctxt, "emacs-gcc-code.c", 0); + } + + gcc_jit_context_set_int_option (comp.ctxt, + GCC_JIT_INT_OPTION_OPTIMIZATION_LEVEL, + opt_level); + + comp.void_type = gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_VOID); + comp.void_ptr_type = + gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_VOID_PTR); + comp.int_type = gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_INT); + comp.unsigned_type = gcc_jit_context_get_type (comp.ctxt, + GCC_JIT_TYPE_UNSIGNED_INT); + comp.bool_type = gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_BOOL); + comp.long_type = gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_LONG); + comp.long_long_type = gcc_jit_context_get_type (comp.ctxt, + GCC_JIT_TYPE_LONG_LONG); + +#if EMACS_INT_MAX <= LONG_MAX + /* 32-bit builds without wide ints, 64-bit builds on Posix hosts. */ + comp.lisp_obj_as_ptr = gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.void_ptr_type, + "obj"); + comp.lisp_obj_as_num = gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.long_long_type, + "num"); + +#else + /* 64-bit builds on MS-Windows, 32-bit builds with wide ints. */ + comp.lisp_obj_as_ptr = gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.long_long_type, + "obj"); + comp.lisp_obj_as_num = gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.long_long_type, + "num"); +#endif + + gcc_jit_field *lisp_obj_fields[2] = { comp.lisp_obj_as_ptr, + comp.lisp_obj_as_num }; + comp.lisp_obj_type = gcc_jit_context_new_union_type (comp.ctxt, + NULL, + "LispObj", + 2, + lisp_obj_fields); + + comp.cast_union_as_ll = + gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.long_long_type, /* FIXME? */ + "ll"); + comp.cast_union_as_u = + gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.unsigned_type, + "u"); + comp.cast_union_as_i = + gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.int_type, + "i"); + comp.cast_union_as_b = + gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.bool_type, + "b"); + + gcc_jit_field *cast_union_fields[4] = + { comp.cast_union_as_ll, + comp.cast_union_as_u, + comp.cast_union_as_i, + comp.cast_union_as_b,}; + comp.cast_union_type = gcc_jit_context_new_union_type (comp.ctxt, + NULL, + "cast_union", + 4, + cast_union_fields); + comp.most_positive_fixnum = + gcc_jit_context_new_rvalue_from_long (comp.ctxt, + comp.long_long_type, /* FIXME? */ + MOST_POSITIVE_FIXNUM); + comp.most_negative_fixnum = + gcc_jit_context_new_rvalue_from_long (comp.ctxt, + comp.long_long_type, /* FIXME? */ + MOST_NEGATIVE_FIXNUM); + comp.one = + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.long_long_type, /* FIXME? */ + 1); + comp.inttypebits = + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.long_long_type, /* FIXME? */ + INTTYPEBITS); + + comp.lisp_int0 = + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.long_long_type, /* FIXME? */ + Lisp_Int0); + + enum gcc_jit_types ptrdiff_t_gcc; + if (sizeof (ptrdiff_t) == sizeof (int)) + ptrdiff_t_gcc = GCC_JIT_TYPE_INT; + else if (sizeof (ptrdiff_t) == sizeof (long int)) + ptrdiff_t_gcc = GCC_JIT_TYPE_LONG; + else if (sizeof (ptrdiff_t) == sizeof (long long int)) + ptrdiff_t_gcc = GCC_JIT_TYPE_LONG_LONG; + else + eassert ("ptrdiff_t size not handled."); + + comp.ptrdiff_type = gcc_jit_context_get_type(comp.ctxt, ptrdiff_t_gcc); + + comp.scratch = + gcc_jit_lvalue_get_address( + gcc_jit_context_new_global (comp.ctxt, NULL, + GCC_JIT_GLOBAL_IMPORTED, + comp.lisp_obj_type, + "scratch_call_area"), + NULL); + + comp.func_hash = CALLN (Fmake_hash_table, QCtest, Qequal, QCweakness, Qt); +} + +static void +release_comp (void) +{ + if (comp.ctxt) + gcc_jit_context_release(comp.ctxt); + + if (logfile) + fclose (logfile); +} + static comp_f_res_t compile_f (const char *f_name, ptrdiff_t bytestr_length, unsigned char *bytestr_data, @@ -1674,6 +1830,7 @@ void emacs_native_compile (const char *lisp_f_name, const char *c_f_name, Lisp_Object func, int opt_level, bool dump_asm) { + init_comp (opt_level); Lisp_Object bytestr = AREF (func, COMPILED_BYTECODE); CHECK_STRING (bytestr); @@ -1698,10 +1855,6 @@ emacs_native_compile (const char *lisp_f_name, const char *c_f_name, sigset_t oldset; block_atimers (&oldset); - gcc_jit_context_set_int_option (comp.ctxt, - GCC_JIT_INT_OPTION_OPTIMIZATION_LEVEL, - opt_level); - comp_f_res_t comp_res = compile_f (c_f_name, bytestr_length, SDATA (bytestr), XFIXNAT (maxdepth) + 1, vectorp, ASIZE (vector), @@ -1724,6 +1877,7 @@ emacs_native_compile (const char *lisp_f_name, const char *c_f_name, DISASS_FILE_NAME); } unblock_atimers (&oldset); + release_comp (); } DEFUN ("native-compile", Fnative_compile, Snative_compile, @@ -1807,158 +1961,6 @@ DEFUN ("native-compile", Fnative_compile, Snative_compile, return Qnil; } -void -init_comp (void) -{ - comp.ctxt = gcc_jit_context_acquire(); - - if (COMP_DEBUG) - { - logfile = fopen ("libgccjit.log", "w"); - gcc_jit_context_set_logfile (comp.ctxt, - logfile, - 0, 0); - gcc_jit_context_set_bool_option (comp.ctxt, - GCC_JIT_BOOL_OPTION_DUMP_EVERYTHING, - 1); - gcc_jit_context_set_bool_option (comp.ctxt, - GCC_JIT_BOOL_OPTION_KEEP_INTERMEDIATES, - 1); - } - if (COMP_DEBUG > 1) - { - gcc_jit_context_dump_reproducer_to_file (comp.ctxt, "comp_reproducer.c"); - gcc_jit_context_dump_to_file (comp.ctxt, "emacs-gcc-code.c", 0); - } - - comp.void_type = gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_VOID); - comp.void_ptr_type = - gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_VOID_PTR); - comp.int_type = gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_INT); - comp.unsigned_type = gcc_jit_context_get_type (comp.ctxt, - GCC_JIT_TYPE_UNSIGNED_INT); - comp.bool_type = gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_BOOL); - comp.long_type = gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_LONG); - comp.long_long_type = gcc_jit_context_get_type (comp.ctxt, - GCC_JIT_TYPE_LONG_LONG); - -#if EMACS_INT_MAX <= LONG_MAX - /* 32-bit builds without wide ints, 64-bit builds on Posix hosts. */ - comp.lisp_obj_as_ptr = gcc_jit_context_new_field (comp.ctxt, - NULL, - comp.void_ptr_type, - "obj"); - comp.lisp_obj_as_num = gcc_jit_context_new_field (comp.ctxt, - NULL, - comp.long_long_type, - "num"); - -#else - /* 64-bit builds on MS-Windows, 32-bit builds with wide ints. */ - comp.lisp_obj_as_ptr = gcc_jit_context_new_field (comp.ctxt, - NULL, - comp.long_long_type, - "obj"); - comp.lisp_obj_as_num = gcc_jit_context_new_field (comp.ctxt, - NULL, - comp.long_long_type, - "num"); -#endif - - gcc_jit_field *lisp_obj_fields[2] = { comp.lisp_obj_as_ptr, - comp.lisp_obj_as_num }; - comp.lisp_obj_type = gcc_jit_context_new_union_type (comp.ctxt, - NULL, - "LispObj", - 2, - lisp_obj_fields); - - comp.cast_union_as_ll = - gcc_jit_context_new_field (comp.ctxt, - NULL, - comp.long_long_type, /* FIXME? */ - "ll"); - comp.cast_union_as_u = - gcc_jit_context_new_field (comp.ctxt, - NULL, - comp.unsigned_type, - "u"); - comp.cast_union_as_i = - gcc_jit_context_new_field (comp.ctxt, - NULL, - comp.int_type, - "i"); - comp.cast_union_as_b = - gcc_jit_context_new_field (comp.ctxt, - NULL, - comp.bool_type, - "b"); - - gcc_jit_field *cast_union_fields[4] = - { comp.cast_union_as_ll, - comp.cast_union_as_u, - comp.cast_union_as_i, - comp.cast_union_as_b,}; - comp.cast_union_type = gcc_jit_context_new_union_type (comp.ctxt, - NULL, - "cast_union", - 4, - cast_union_fields); - comp.most_positive_fixnum = - gcc_jit_context_new_rvalue_from_long (comp.ctxt, - comp.long_long_type, /* FIXME? */ - MOST_POSITIVE_FIXNUM); - comp.most_negative_fixnum = - gcc_jit_context_new_rvalue_from_long (comp.ctxt, - comp.long_long_type, /* FIXME? */ - MOST_NEGATIVE_FIXNUM); - comp.one = - gcc_jit_context_new_rvalue_from_int (comp.ctxt, - comp.long_long_type, /* FIXME? */ - 1); - comp.inttypebits = - gcc_jit_context_new_rvalue_from_int (comp.ctxt, - comp.long_long_type, /* FIXME? */ - INTTYPEBITS); - - comp.lisp_int0 = - gcc_jit_context_new_rvalue_from_int (comp.ctxt, - comp.long_long_type, /* FIXME? */ - Lisp_Int0); - - enum gcc_jit_types ptrdiff_t_gcc; - if (sizeof (ptrdiff_t) == sizeof (int)) - ptrdiff_t_gcc = GCC_JIT_TYPE_INT; - else if (sizeof (ptrdiff_t) == sizeof (long int)) - ptrdiff_t_gcc = GCC_JIT_TYPE_LONG; - else if (sizeof (ptrdiff_t) == sizeof (long long int)) - ptrdiff_t_gcc = GCC_JIT_TYPE_LONG_LONG; - else - eassert ("ptrdiff_t size not handled."); - - comp.ptrdiff_type = gcc_jit_context_get_type(comp.ctxt, ptrdiff_t_gcc); - - comp.scratch = - gcc_jit_lvalue_get_address( - gcc_jit_context_new_global (comp.ctxt, NULL, - GCC_JIT_GLOBAL_IMPORTED, - comp.lisp_obj_type, - "scratch_call_area"), - NULL); - - comp.func_hash = CALLN (Fmake_hash_table, QCtest, Qequal, QCweakness, Qt); -} - -void -release_comp (void) -{ - if (comp.ctxt) - gcc_jit_context_release(comp.ctxt); - - if (logfile) - fclose (logfile); -} - void syms_of_comp (void) { diff --git a/src/emacs.c b/src/emacs.c index db6d54dff4..1491ba5a47 100644 --- a/src/emacs.c +++ b/src/emacs.c @@ -1778,12 +1778,6 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem xputenv ("LANG=C"); #endif - /* This is here because init_buffer can already call Lisp. */ -#ifdef HAVE_LIBGCCJIT - if (initialized) - init_comp(); -#endif - /* Init buffer storage and default directory of main buffer. */ init_buffer (); @@ -2400,10 +2394,6 @@ all of which are called before Emacs is actually killed. */ unlink (SSDATA (listfile)); } -#ifdef HAVE_LIBGCCJIT - release_comp(); -#endif - if (FIXNUMP (arg)) exit_code = (XFIXNUM (arg) < 0 ? XFIXNUM (arg) | INT_MIN diff --git a/src/lisp.h b/src/lisp.h index 5a563069df..6f0177436d 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -4745,8 +4745,6 @@ extern void syms_of_profiler (void); /* Defined in comp.c. */ #ifdef HAVE_LIBGCCJIT -extern void init_comp (void); -extern void release_comp (void); extern void syms_of_comp (void); #endif /* HAVE_LIBGCCJIT */ commit f3fd0293d9112e5e1ad9ad3bfb1e982dcb0d032b Author: Andrea Corallo Date: Thu Jun 13 00:36:01 2019 +0200 make some order into debug facilities diff --git a/src/comp.c b/src/comp.c index 3c837555d7..79aa0bdc03 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1812,8 +1812,24 @@ init_comp (void) { comp.ctxt = gcc_jit_context_acquire(); + if (COMP_DEBUG) + { + logfile = fopen ("libgccjit.log", "w"); + gcc_jit_context_set_logfile (comp.ctxt, + logfile, + 0, 0); + gcc_jit_context_set_bool_option (comp.ctxt, + GCC_JIT_BOOL_OPTION_DUMP_EVERYTHING, + 1); + gcc_jit_context_set_bool_option (comp.ctxt, + GCC_JIT_BOOL_OPTION_KEEP_INTERMEDIATES, + 1); + } if (COMP_DEBUG > 1) - gcc_jit_context_dump_reproducer_to_file (comp.ctxt, "comp_reproducer.c"); + { + gcc_jit_context_dump_reproducer_to_file (comp.ctxt, "comp_reproducer.c"); + gcc_jit_context_dump_to_file (comp.ctxt, "emacs-gcc-code.c", 0); + } comp.void_type = gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_VOID); comp.void_ptr_type = @@ -1931,20 +1947,6 @@ init_comp (void) NULL); comp.func_hash = CALLN (Fmake_hash_table, QCtest, Qequal, QCweakness, Qt); - - if (COMP_DEBUG) { - logfile = fopen ("libgccjit.log", "w"); - gcc_jit_context_set_logfile (comp.ctxt, - logfile, - 0, 0); - gcc_jit_context_set_bool_option (comp.ctxt, - GCC_JIT_BOOL_OPTION_DUMP_EVERYTHING, - 1); - } - - gcc_jit_context_set_bool_option (comp.ctxt, - GCC_JIT_BOOL_OPTION_KEEP_INTERMEDIATES, - 1); } void commit d6ab30499153b2d6b9565039714f210930a10f65 Author: Andrea Corallo Date: Wed Jun 12 22:11:20 2019 +0200 add comp_VECTORLIKEP diff --git a/src/comp.c b/src/comp.c index d4f08df48e..3c837555d7 100644 --- a/src/comp.c +++ b/src/comp.c @@ -329,6 +329,12 @@ comp_TAGGEDP (gcc_jit_rvalue *obj, unsigned tag) return res; } +static gcc_jit_rvalue * +comp_VECTORLIKEP (gcc_jit_rvalue *obj) +{ + return comp_TAGGEDP(obj, Lisp_Vectorlike); +} + static gcc_jit_rvalue * comp_CONSP (gcc_jit_rvalue *obj) { commit 592bfe5a978c949883472e66bd6c00f58808a506 Author: Andrea Corallo Date: Wed Jun 12 18:21:32 2019 +0200 adding other ops diff --git a/src/comp.c b/src/comp.c index 93edd4df45..d4f08df48e 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1288,7 +1288,15 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, EMIT_SCRATCH_CALL_N ("Ftimes", 2); break; case Bpoint: - error ("Bpoint unsupported bytecode\n"); + args[0] = + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.ptrdiff_type, + PT); + res = comp_emit_call ("make_fixed_natnum", + comp.lisp_obj_type, + 1, + args); + PUSH_LVAL (res); break; CASE_CALL_NARGS (goto_char, 1); @@ -1298,10 +1306,27 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, break; case Bpoint_max: - error ("Bpoint_max unsupported bytecode\n"); + args[0] = + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.ptrdiff_type, + ZV); + res = comp_emit_call ("make_fixed_natnum", + comp.lisp_obj_type, + 1, + args); + PUSH_LVAL (res); break; + case Bpoint_min: - error ("Bpoint_min unsupported bytecode\n"); + args[0] = + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.ptrdiff_type, + BEGV); + res = comp_emit_call ("make_fixed_natnum", + comp.lisp_obj_type, + 1, + args); + PUSH_LVAL (res); break; CASE_CALL_NARGS (char_after, 1); @@ -1322,17 +1347,9 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, break; CASE_CALL_NARGS (eolp, 0); - - case Beobp: - error ("Beobp unsupported bytecode\n"); - break; - + CASE_CALL_NARGS (eobp, 0); CASE_CALL_NARGS (bolp, 0); - - case Bbobp: - error ("Bbobp unsupported bytecode\n"); - break; - + CASE_CALL_NARGS (bobp, 0); CASE_CALL_NARGS (current_buffer, 0); CASE_CALL_NARGS (set_buffer, 1); @@ -1482,76 +1499,54 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, but will be needed for tail-recursion elimination. */ error ("Bunbind_all not supported"); break; - case Bset_marker: - error ("Bset_marker not supported"); - break; - case Bmatch_beginning: - error ("Bmatch_beginning not supported"); - break; - case Bmatch_end: - error ("Bmatch_end not supported"); - break; - case Bupcase: - error ("Bupcase not supported"); - break; - case Bdowncase: - error ("Bdowncase not supported"); - break; - case Bstringeqlsign: - error ("Bstringeqlsign not supported"); - break; - case Bstringlss: - error ("Bstringlss not supported"); - break; - case Bequal: - error ("Bequal not supported"); - break; - case Bnthcdr: - error ("Bnthcdr not supported"); - break; - case Belt: - error ("Belt not supported"); - break; - case Bmember: - error ("Bmember not supported"); - break; - case Bassq: - error ("Bassq not supported"); - break; - case Bnreverse: - error ("Bnreverse not supported"); - break; - case Bsetcar: + CASE_CALL_NARGS (set_marker, 3); + CASE_CALL_NARGS (match_beginning, 1); + CASE_CALL_NARGS (match_end, 1); + CASE_CALL_NARGS (upcase, 1); + CASE_CALL_NARGS (downcase, 1); + + case Bstringeqlsign: POP2; - res = comp_emit_call ("Fsetcar", comp.lisp_obj_type, 2, args); + res = comp_emit_call ("Fstring_equal", comp.lisp_obj_type, 2, args); PUSH_LVAL (res); break; - case Bsetcdr: + case Bstringlss: POP2; - res = comp_emit_call ("Fsetcdr", comp.lisp_obj_type, 2, args); + res = comp_emit_call ("Fstring_lessp", comp.lisp_obj_type, 2, args); PUSH_LVAL (res); break; + CASE_CALL_NARGS (equal, 2); + CASE_CALL_NARGS (nthcdr, 2); + CASE_CALL_NARGS (elt, 2); + CASE_CALL_NARGS (member, 2); + CASE_CALL_NARGS (assq, 2); + CASE_CALL_NARGS (setcar, 2); + CASE_CALL_NARGS (setcdr, 2); + case Bcar_safe: error ("Bcar_safe not supported"); break; case Bcdr_safe: error ("Bcdr_safe not supported"); break; + case Bnconc: - error ("Bnconc not supported"); + EMIT_SCRATCH_CALL_N ("Fnconc", 2); break; + case Bquo: - error ("Bquo not supported"); - break; - case Brem: - error ("Brem not supported"); + EMIT_SCRATCH_CALL_N ("Fquo", 2); break; + + CASE_CALL_NARGS (rem, 2); + case Bnumberp: error ("Bnumberp not supported"); break; + case Bintegerp: error ("Bintegerp not supported"); break; @@ -1932,7 +1927,7 @@ init_comp (void) comp.func_hash = CALLN (Fmake_hash_table, QCtest, Qequal, QCweakness, Qt); if (COMP_DEBUG) { - logfile = fopen ("libjit.log", "w"); + logfile = fopen ("libgccjit.log", "w"); gcc_jit_context_set_logfile (comp.ctxt, logfile, 0, 0); @@ -2009,4 +2004,4 @@ helper_unbind_n (int val) return unbind_to (SPECPDL_INDEX () - val, Qnil); } -#endif /* HAVE_LIBJIT */ +#endif /* HAVE_LIBGCCJIT */ commit b3d858da8d577449e2ab40572422fdd1bdf8b538 Author: Andrea Corallo Date: Tue Jun 11 19:41:34 2019 +0200 inline consp diff --git a/src/comp.c b/src/comp.c index 823956e147..93edd4df45 100644 --- a/src/comp.c +++ b/src/comp.c @@ -329,6 +329,12 @@ comp_TAGGEDP (gcc_jit_rvalue *obj, unsigned tag) return res; } +static gcc_jit_rvalue * +comp_CONSP (gcc_jit_rvalue *obj) +{ + return comp_TAGGEDP(obj, Lisp_Cons); +} + static gcc_jit_rvalue * comp_FIXNUMP (gcc_jit_rvalue *obj) { @@ -1004,7 +1010,15 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, CASE_CALL_NARGS (nth, 2); CASE_CALL_NARGS (symbolp, 1); - CASE_CALL_NARGS (consp, 1); + + case Bconsp: + gcc_jit_block_add_assignment ( + comp.bblock->gcc_bb, + NULL, + TOS, + comp_CONSP(gcc_jit_lvalue_as_rvalue (TOS))); + break; + CASE_CALL_NARGS (stringp, 1); CASE_CALL_NARGS (listp, 1); CASE_CALL_NARGS (eq, 2); diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 74ed33a43c..63dfafafb0 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -272,6 +272,15 @@ (should (equal (comp-bubble-sort-f list1) (sort list2 #'<))))) +(ert-deftest comp-tests-list-inline () + "Test some inlined list functions." + (defun comp-tests-consp-f (x) + ;; Bconsp + (consp x)) + + (should (eq (comp-tests-consp-f '(1)) t)) + (should (eq (comp-tests-consp-f 1) nil))) + (ert-deftest comp-tests-gc () "Try to do some longer computation to let the gc kick in." (dotimes (_ 100000) commit 4da353c6a3900ddacab00d685432fba12099dbd0 Author: Andrea Corallo Date: Tue Jun 11 19:23:31 2019 +0200 add comp_TAGGEDP diff --git a/src/comp.c b/src/comp.c index 97b617ce2b..823956e147 100644 --- a/src/comp.c +++ b/src/comp.c @@ -281,6 +281,54 @@ comp_XLI (gcc_jit_rvalue *obj) comp.lisp_obj_as_num); } +static gcc_jit_rvalue * +comp_TAGGEDP (gcc_jit_rvalue *obj, unsigned tag) +{ + /* (! (((unsigned) (XLI (a) >> (USE_LSB_TAG ? 0 : VALBITS)) \ + - (unsigned) (tag)) \ + & ((1 << GCTYPEBITS) - 1))) */ + + gcc_jit_rvalue *sh_res = + gcc_jit_context_new_binary_op ( + comp.ctxt, + NULL, + GCC_JIT_BINARY_OP_RSHIFT, + comp.long_long_type, + comp_XLI (obj), + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.long_long_type, + (USE_LSB_TAG ? 0 : VALBITS))); + + gcc_jit_rvalue *minus_res = + gcc_jit_context_new_binary_op (comp.ctxt, + NULL, + GCC_JIT_BINARY_OP_MINUS, + comp.unsigned_type, + comp_cast (comp.unsigned_type, sh_res), + gcc_jit_context_new_rvalue_from_int ( + comp.ctxt, + comp.unsigned_type, + tag)); + + gcc_jit_rvalue *res = + gcc_jit_context_new_unary_op ( + comp.ctxt, + NULL, + GCC_JIT_UNARY_OP_LOGICAL_NEGATE, + comp.int_type, + gcc_jit_context_new_binary_op (comp.ctxt, + NULL, + GCC_JIT_BINARY_OP_BITWISE_AND, + comp.unsigned_type, + minus_res, + gcc_jit_context_new_rvalue_from_int ( + comp.ctxt, + comp.unsigned_type, + ((1 << GCTYPEBITS) - 1)))); + + return res; +} + static gcc_jit_rvalue * comp_FIXNUMP (gcc_jit_rvalue *obj) { commit 1001af9b847c1c338638ba1aee037dd8451882d0 Author: Andrea Corallo Date: Tue Jun 11 18:56:25 2019 +0200 add bubble sort into to tests diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index e7d5ca67f4..74ed33a43c 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -250,6 +250,28 @@ (should (equal (comp-tests-setcar-f '(10 . 10) 3) '(3 . 10))) (should (equal (comp-tests-setcdr-f '(10 . 10) 3) '(10 . 3)))) +(defun comp-bubble-sort () + "Run bubble sort." + (defun comp-bubble-sort-f (list) + (let ((i (length list))) + (while (> i 1) + (let ((b list)) + (while (cdr b) + (when (< (cadr b) (car b)) + (setcar b (prog1 (cadr b) + (setcdr b (cons (car b) (cddr b)))))) + (setq b (cdr b)))) + (setq i (1- i))) + list)) + + (byte-compile #'comp-bubble-sort-f) + (native-compile #'comp-bubble-sort-f) + + (let* ((list1 (mapcar 'random (make-list 1000 most-positive-fixnum))) + (list2 (copy-sequence list1))) + (should (equal (comp-bubble-sort-f list1) + (sort list2 #'<))))) + (ert-deftest comp-tests-gc () "Try to do some longer computation to let the gc kick in." (dotimes (_ 100000) commit 87bf022f2f5457febf23c2ce792c549928771bbd Author: Andrea Corallo Date: Wed Jun 12 03:54:59 2019 +0200 fix prologue strategy diff --git a/src/comp.c b/src/comp.c index a14056e4c5..97b617ce2b 100644 --- a/src/comp.c +++ b/src/comp.c @@ -70,7 +70,7 @@ along with GNU Emacs. If not, see . */ #define PUSH_PARAM(obj) \ do { \ CHECK_STACK; \ - gcc_jit_block_add_assignment (bb_map[0].gcc_bb, \ + gcc_jit_block_add_assignment (prologue_bb, \ NULL, \ *stack, \ gcc_jit_param_as_rvalue(obj)); \ @@ -729,7 +729,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, gcc_jit_rvalue *args[4]; unsigned op; - /* This is the stack we use to flat the bytecode written for push and pop + /* Meta-stack we use to flat the bytecode written for push and pop Emacs VM.*/ gcc_jit_lvalue **stack_base, **stack, **stack_over; stack_base = stack = @@ -772,10 +772,14 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, local_name); } + gcc_jit_block *prologue_bb = + gcc_jit_function_new_block (comp.func, "prologue"); + basic_block_t *bb_map = compute_bblocks (bytestr_length, bytestr_data); for (ptrdiff_t i = 0; i < comp_res.max_args; ++i) PUSH_PARAM (gcc_jit_function_get_param (comp.func, i)); + gcc_jit_block_end_with_jump (prologue_bb, NULL, bb_map[0].gcc_bb); gcc_jit_rvalue *nil = comp_lisp_obj_as_ptr_from_ptr (&bb_map[0], Qnil); commit 203b6ce9fa148ca05fc2688a8a1a607dc922acd7 Author: Andrea Corallo Date: Wed Jun 12 03:36:46 2019 +0200 improve comp_lisp_obj_as_ptr_from_ptr generated var naming diff --git a/src/comp.c b/src/comp.c index 5fd11e7a7e..a14056e4c5 100644 --- a/src/comp.c +++ b/src/comp.c @@ -379,10 +379,18 @@ comp_make_fixnum (gcc_jit_block *block, gcc_jit_rvalue *obj) static gcc_jit_rvalue * comp_lisp_obj_as_ptr_from_ptr (basic_block_t *bblock, void *p) { + static unsigned i; + char ptr_var_name[40]; + + int res = snprintf (ptr_var_name, sizeof (ptr_var_name), + "lisp_obj_from_ptr_%u", i++); + if (res >= sizeof (ptr_var_name)) + error ("Internal error, truncating temporary variable"); + gcc_jit_lvalue *lisp_obj = gcc_jit_function_new_local (comp.func, NULL, comp.lisp_obj_type, - "lisp_obj_from_ptr"); + ptr_var_name); gcc_jit_lvalue *lisp_obj_as_ptr = gcc_jit_lvalue_access_field (lisp_obj, NULL, commit edcadf5c440a95c0c6a564d89eb9beac64e229fc Author: Andrea Corallo Date: Wed Jun 12 03:36:31 2019 +0200 add Bstack_set diff --git a/src/comp.c b/src/comp.c index aa4bb7fa45..5fd11e7a7e 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1530,9 +1530,18 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, case BinsertN: error ("BinsertN not supported"); break; + case Bstack_set: - error ("Bstack_set not supported"); + /* stack-set-0 = discard; stack-set-1 = discard-1-preserve-tos. */ + op = FETCH; + POP1; + if (op > 0) + gcc_jit_block_add_assignment (comp.bblock->gcc_bb, + NULL, + *(stack - op), + args[0]); break; + case Bstack_set2: error ("Bstack_set2 not supported"); break; commit 3ee58c64e57cde232a062cb199688b2686488ef1 Author: Andrea Corallo Date: Tue Jun 11 23:47:16 2019 +0200 add setcar setcdr diff --git a/src/comp.c b/src/comp.c index 1c2a5818be..aa4bb7fa45 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1447,12 +1447,19 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, case Bnreverse: error ("Bnreverse not supported"); break; + case Bsetcar: - error ("Bsetcar not supported"); + POP2; + res = comp_emit_call ("Fsetcar", comp.lisp_obj_type, 2, args); + PUSH_LVAL (res); break; + case Bsetcdr: - error ("Bsetcdr not supported"); + POP2; + res = comp_emit_call ("Fsetcdr", comp.lisp_obj_type, 2, args); + PUSH_LVAL (res); break; + case Bcar_safe: error ("Bcar_safe not supported"); break; diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index f83fa8c8be..e7d5ca67f4 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -233,6 +233,23 @@ (should (eq (comp-tests-geq-f 3 3) t)) (should (eq (comp-tests-geq-f 2 3) nil))) +(ert-deftest comp-tests-setcarcdr () + "Testing setcar setcdr." + (defun comp-tests-setcar-f (x y) + (setcar x y) + x) + (defun comp-tests-setcdr-f (x y) + (setcdr x y) + x) + + (byte-compile #'comp-tests-setcar-f) + (byte-compile #'comp-tests-setcdr-f) + (native-compile #'comp-tests-setcar-f) + (native-compile #'comp-tests-setcdr-f) + + (should (equal (comp-tests-setcar-f '(10 . 10) 3) '(3 . 10))) + (should (equal (comp-tests-setcdr-f '(10 . 10) 3) '(10 . 3)))) + (ert-deftest comp-tests-gc () "Try to do some longer computation to let the gc kick in." (dotimes (_ 100000) commit 5c406adac75e1b007545991fb7f20068bcaa5b22 Author: Andrea Corallo Date: Tue Jun 11 23:40:29 2019 +0200 add arithmetic comparisons diff --git a/src/comp.c b/src/comp.c index 712fd01af0..1c2a5818be 100644 --- a/src/comp.c +++ b/src/comp.c @@ -141,6 +141,17 @@ along with GNU Emacs. If not, see . */ PUSH_LVAL (res); \ } while (0) +#define EMIT_ARITHCOMPARE(comparison) \ + do { \ + POP2; \ + args[2] = gcc_jit_context_new_rvalue_from_int (comp.ctxt, \ + comp.int_type, \ + comparison); \ + res = comp_emit_call ("arithcompare", comp.lisp_obj_type, 3, args); \ + PUSH_LVAL (res); \ + } while (0) + + typedef struct { gcc_jit_block *gcc_bb; bool terminated; @@ -192,9 +203,6 @@ typedef struct { short min_args, max_args; } comp_f_res_t; -INLINE static void pop (unsigned n, gcc_jit_lvalue ***stack_ref, - gcc_jit_rvalue *args[]); - void emacs_native_compile (const char *lisp_f_name, const char *c_f_name, Lisp_Object func, int opt_level, bool dump_asm); @@ -1113,24 +1121,31 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, bb_map[pc].gcc_bb); } break; + case Beqlsign: - error ("Beqlsign unsupported bytecode\n"); + EMIT_ARITHCOMPARE (ARITH_EQUAL); break; + case Bgtr: - error ("Bgtr unsupported bytecode\n"); + EMIT_ARITHCOMPARE (ARITH_GRTR); break; + case Blss: - error ("Blss unsupported bytecode\n"); + EMIT_ARITHCOMPARE (ARITH_LESS); break; + case Bleq: - error ("Bleq unsupported bytecode\n"); + EMIT_ARITHCOMPARE (ARITH_LESS_OR_EQUAL); break; + case Bgeq: - error ("Bgeq unsupported bytecode\n"); + EMIT_ARITHCOMPARE (ARITH_GRTR_OR_EQUAL); break; + case Bdiff: EMIT_SCRATCH_CALL_N ("Fminus", 2); break; + case Bnegate: { diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index dc2c396392..f83fa8c8be 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -187,6 +187,52 @@ (error err)) '(wrong-type-argument number-or-marker-p a)))) +(ert-deftest comp-tests-arith-comp () + "Testing arithmetic comparisons." + (defun comp-tests-eqlsign-f (x y) + ;; Beqlsign + (= x y)) + (defun comp-tests-gtr-f (x y) + ;; Bgtr + (> x y)) + (defun comp-tests-lss-f (x y) + ;; Blss + (< x y)) + (defun comp-tests-les-f (x y) + ;; Bleq + (<= x y)) + (defun comp-tests-geq-f (x y) + ;; Bgeq + (>= x y)) + + (byte-compile #'comp-tests-eqlsign-f) + (byte-compile #'comp-tests-gtr-f) + (byte-compile #'comp-tests-lss-f) + (byte-compile #'comp-tests-les-f) + (byte-compile #'comp-tests-geq-f) + + (native-compile #'comp-tests-eqlsign-f) + (native-compile #'comp-tests-gtr-f) + (native-compile #'comp-tests-lss-f) + (native-compile #'comp-tests-les-f) + (native-compile #'comp-tests-geq-f) + + (should (eq (comp-tests-eqlsign-f 4 3) nil)) + (should (eq (comp-tests-eqlsign-f 3 3) t)) + (should (eq (comp-tests-eqlsign-f 2 3) nil)) + (should (eq (comp-tests-gtr-f 4 3) t)) + (should (eq (comp-tests-gtr-f 3 3) nil)) + (should (eq (comp-tests-gtr-f 2 3) nil)) + (should (eq (comp-tests-lss-f 4 3) nil)) + (should (eq (comp-tests-lss-f 3 3) nil)) + (should (eq (comp-tests-lss-f 2 3) t)) + (should (eq (comp-tests-les-f 4 3) nil)) + (should (eq (comp-tests-les-f 3 3) t)) + (should (eq (comp-tests-les-f 2 3) t)) + (should (eq (comp-tests-geq-f 4 3) t)) + (should (eq (comp-tests-geq-f 3 3) t)) + (should (eq (comp-tests-geq-f 2 3) nil))) + (ert-deftest comp-tests-gc () "Try to do some longer computation to let the gc kick in." (dotimes (_ 100000) commit 7ce2c17a0fbde3203f311c6b91d8bb2ba77adeda Author: Andrea Corallo Date: Mon Jun 10 11:02:47 2019 +0200 add Bnegate support diff --git a/src/comp.c b/src/comp.c index d92e482226..712fd01af0 100644 --- a/src/comp.c +++ b/src/comp.c @@ -634,6 +634,7 @@ compute_bblocks (ptrdiff_t bytestr_length, unsigned char *bytestr_data) break; case Bsub1: case Badd1: + case Bnegate: case Breturn: new_bb = true; break; @@ -997,8 +998,8 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, { /* (FIXNUMP (TOP) && XFIXNUM (TOP) != MOST_NEGATIVE_FIXNUM - ? make_fixnum (XFIXNUM (TOP) - 1) - : Fsub1 (TOP)) */ + ? make_fixnum (XFIXNUM (TOP) - 1) + : Fsub1 (TOP)) */ gcc_jit_block *sub1_inline_block = gcc_jit_function_new_block (comp.func, "inline_sub1"); @@ -1057,8 +1058,8 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, { /* (FIXNUMP (TOP) && XFIXNUM (TOP) != MOST_POSITIVE_FIXNUM - ? make_fixnum (XFIXNUM (TOP) + 1) - : Fadd (TOP)) */ + ? make_fixnum (XFIXNUM (TOP) + 1) + : Fadd (TOP)) */ gcc_jit_block *add1_inline_block = gcc_jit_function_new_block (comp.func, "inline_add1"); @@ -1131,7 +1132,59 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, EMIT_SCRATCH_CALL_N ("Fminus", 2); break; case Bnegate: - error ("Bnegate unsupported bytecode\n"); + { + + /* (FIXNUMP (TOP) && XFIXNUM (TOP) != MOST_NEGATIVE_FIXNUM + ? make_fixnum (- XFIXNUM (TOP)) + : Fminus (1, &TOP)) */ + + gcc_jit_block *negate_inline_block = + gcc_jit_function_new_block (comp.func, "inline_negate"); + gcc_jit_block *negate_fcall_block = + gcc_jit_function_new_block (comp.func, "fcall_negate"); + + gcc_jit_rvalue *tos_as_num = + comp_XFIXNUM (gcc_jit_lvalue_as_rvalue (TOS)); + + comp_emit_cond_jump ( + gcc_jit_context_new_binary_op ( + comp.ctxt, + NULL, + GCC_JIT_BINARY_OP_LOGICAL_AND, + comp.bool_type, + comp_cast (comp.bool_type, + comp_FIXNUMP (gcc_jit_lvalue_as_rvalue (TOS))), + gcc_jit_context_new_comparison (comp.ctxt, + NULL, + GCC_JIT_COMPARISON_NE, + tos_as_num, + comp.most_negative_fixnum)), + negate_inline_block, + negate_fcall_block); + + gcc_jit_rvalue *negate_inline_res = + gcc_jit_context_new_unary_op (comp.ctxt, + NULL, + GCC_JIT_UNARY_OP_MINUS, + comp.long_long_type, + tos_as_num); + + gcc_jit_block_add_assignment (negate_inline_block, + NULL, + TOS, + comp_make_fixnum (negate_inline_block, + negate_inline_res)); + basic_block_t bb_orig = *comp.bblock; + + comp.bblock->gcc_bb = negate_fcall_block; + EMIT_SCRATCH_CALL_N ("Fminus", 1); + *comp.bblock = bb_orig; + + gcc_jit_block_end_with_jump (negate_inline_block, NULL, + bb_map[pc].gcc_bb); + gcc_jit_block_end_with_jump (negate_fcall_block, NULL, + bb_map[pc].gcc_bb); + } break; case Bplus: EMIT_SCRATCH_CALL_N ("Fplus", 2); diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 06c7697be7..dc2c396392 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -148,28 +148,42 @@ (ert-deftest comp-tests-fixnum () "Testing some fixnum inline operation." - (defun comp-tests-fixnum-1--f (x) + (defun comp-tests-fixnum-1-minus-f (x) + ;; Bsub1 (1- x)) - (defun comp-tests-fixnum-1+-f (x) + (defun comp-tests-fixnum-1-plus-f (x) + ;; Badd1 (1+ x)) - - (byte-compile #'comp-tests-fixnum-1--f) - (byte-compile #'comp-tests-fixnum-1+-f) - ;; (native-compile #'comp-tests-fixnum-1--f) - (native-compile #'comp-tests-fixnum-1+-f) - - (should (= (comp-tests-fixnum-1--f 10) 9)) - (should (= (comp-tests-fixnum-1--f most-negative-fixnum) + (defun comp-tests-fixnum-minus-f (x) + ;; Bnegate + (- x)) + + (byte-compile #'comp-tests-fixnum-1-minus-f) + (byte-compile #'comp-tests-fixnum-1-plus-f) + (byte-compile #'comp-tests-fixnum-minus-f) + (native-compile #'comp-tests-fixnum-1-minus-f) + (native-compile #'comp-tests-fixnum-1-plus-f) + (native-compile #'comp-tests-fixnum-minus-f) + + (should (= (comp-tests-fixnum-1-minus-f 10) 9)) + (should (= (comp-tests-fixnum-1-minus-f most-negative-fixnum) (1- most-negative-fixnum))) (should (equal (condition-case err - (comp-tests-fixnum-1--f 'a) + (comp-tests-fixnum-1-minus-f 'a) (error err)) '(wrong-type-argument number-or-marker-p a))) - (should (= (comp-tests-fixnum-1+-f 10) 11)) - (should (= (comp-tests-fixnum-1+-f most-positive-fixnum) + (should (= (comp-tests-fixnum-1-plus-f 10) 11)) + (should (= (comp-tests-fixnum-1-plus-f most-positive-fixnum) (1+ most-positive-fixnum))) (should (equal (condition-case err - (comp-tests-fixnum-1+-f 'a) + (comp-tests-fixnum-1-plus-f 'a) + (error err)) + '(wrong-type-argument number-or-marker-p a))) + (should (= (comp-tests-fixnum-minus-f 10) -10)) + (should (= (comp-tests-fixnum-minus-f most-negative-fixnum) + (- most-negative-fixnum))) + (should (equal (condition-case err + (comp-tests-fixnum-minus-f 'a) (error err)) '(wrong-type-argument number-or-marker-p a)))) commit 65eb55ff4194c67ede020ceabd7b92e7d2128908 Author: Andrea Corallo Date: Mon Jun 10 10:38:14 2019 +0200 code cleanup diff --git a/src/comp.c b/src/comp.c index 3cb5189295..d92e482226 100644 --- a/src/comp.c +++ b/src/comp.c @@ -652,10 +652,6 @@ compute_bblocks (ptrdiff_t bytestr_length, unsigned char *bytestr_data) bb_n = j + 1; } - /* for (int i = 0; i < bb_n; i++) */ - /* printf ("%d ", bb_start_pc[i]); */ - /* printf ("\n"); */ - basic_block_t curr_bb; for (int i = 0, pc = 0; pc < bytestr_length; pc++) { @@ -1492,7 +1488,6 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, gcc_jit_rvalue *c = comp_lisp_obj_as_ptr_from_ptr (comp.bblock, vectorp[op]); PUSH_RVAL (c); - /* Fprint(vectorp[op], Qnil); */ break; } @@ -1511,8 +1506,6 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, error ("Something went wrong"); exit: - /* if (nil_ret_bb) */ - /* xfree (nil_ret_bb); */ xfree (stack_base); xfree (bb_map); return comp_res; commit 097f36bc75a6570e64f80451ae4bbe2172d610e0 Author: Andrea Corallo Date: Mon Jun 10 10:34:04 2019 +0200 add Badd1 support diff --git a/src/comp.c b/src/comp.c index ede417c794..3cb5189295 100644 --- a/src/comp.c +++ b/src/comp.c @@ -633,6 +633,7 @@ compute_bblocks (ptrdiff_t bytestr_length, unsigned char *bytestr_data) new_bb = true; break; case Bsub1: + case Badd1: case Breturn: new_bb = true; break; @@ -1004,9 +1005,9 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, : Fsub1 (TOP)) */ gcc_jit_block *sub1_inline_block = - gcc_jit_function_new_block (comp.func, "inline-1"); + gcc_jit_function_new_block (comp.func, "inline_sub1"); gcc_jit_block *sub1_fcall_block = - gcc_jit_function_new_block (comp.func, "fcall-1"); + gcc_jit_function_new_block (comp.func, "fcall_sub1"); gcc_jit_rvalue *tos_as_num = comp_XFIXNUM (gcc_jit_lvalue_as_rvalue (TOS)); @@ -1057,7 +1058,63 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, break; case Badd1: - error ("Badd1 unsupported bytecode\n"); + { + + /* (FIXNUMP (TOP) && XFIXNUM (TOP) != MOST_POSITIVE_FIXNUM + ? make_fixnum (XFIXNUM (TOP) + 1) + : Fadd (TOP)) */ + + gcc_jit_block *add1_inline_block = + gcc_jit_function_new_block (comp.func, "inline_add1"); + gcc_jit_block *add1_fcall_block = + gcc_jit_function_new_block (comp.func, "fcall_add1"); + + gcc_jit_rvalue *tos_as_num = + comp_XFIXNUM (gcc_jit_lvalue_as_rvalue (TOS)); + + comp_emit_cond_jump ( + gcc_jit_context_new_binary_op ( + comp.ctxt, + NULL, + GCC_JIT_BINARY_OP_LOGICAL_AND, + comp.bool_type, + comp_cast (comp.bool_type, + comp_FIXNUMP (gcc_jit_lvalue_as_rvalue (TOS))), + gcc_jit_context_new_comparison (comp.ctxt, + NULL, + GCC_JIT_COMPARISON_NE, + tos_as_num, + comp.most_positive_fixnum)), + add1_inline_block, + add1_fcall_block); + + gcc_jit_rvalue *add1_inline_res = + gcc_jit_context_new_binary_op (comp.ctxt, + NULL, + GCC_JIT_BINARY_OP_PLUS, + comp.long_long_type, + tos_as_num, + comp.one); + + gcc_jit_block_add_assignment (add1_inline_block, + NULL, + TOS, + comp_make_fixnum (add1_inline_block, + add1_inline_res)); + basic_block_t bb_orig = *comp.bblock; + + comp.bblock->gcc_bb = add1_fcall_block; + POP1; + res = comp_emit_call ("Fadd1", comp.lisp_obj_type, 1, args); + PUSH_LVAL (res); + + *comp.bblock = bb_orig; + + gcc_jit_block_end_with_jump (add1_inline_block, NULL, + bb_map[pc].gcc_bb); + gcc_jit_block_end_with_jump (add1_fcall_block, NULL, + bb_map[pc].gcc_bb); + } break; case Beqlsign: error ("Beqlsign unsupported bytecode\n"); diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index e13db89ddc..06c7697be7 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -148,18 +148,29 @@ (ert-deftest comp-tests-fixnum () "Testing some fixnum inline operation." - (defun comp-tests-fixnum-1-f (x) + (defun comp-tests-fixnum-1--f (x) (1- x)) + (defun comp-tests-fixnum-1+-f (x) + (1+ x)) - (byte-compile #'comp-tests-fixnum-1-f) - (native-compile #'comp-tests-fixnum-1-f) + (byte-compile #'comp-tests-fixnum-1--f) + (byte-compile #'comp-tests-fixnum-1+-f) + ;; (native-compile #'comp-tests-fixnum-1--f) + (native-compile #'comp-tests-fixnum-1+-f) - (should (= (comp-tests-fixnum-1-f 10) 9)) - (should (= (comp-tests-fixnum-1-f most-negative-fixnum) + (should (= (comp-tests-fixnum-1--f 10) 9)) + (should (= (comp-tests-fixnum-1--f most-negative-fixnum) (1- most-negative-fixnum))) (should (equal (condition-case err - (comp-tests-fixnum-1-f 'a) - (error (print err))) + (comp-tests-fixnum-1--f 'a) + (error err)) + '(wrong-type-argument number-or-marker-p a))) + (should (= (comp-tests-fixnum-1+-f 10) 11)) + (should (= (comp-tests-fixnum-1+-f most-positive-fixnum) + (1+ most-positive-fixnum))) + (should (equal (condition-case err + (comp-tests-fixnum-1+-f 'a) + (error err)) '(wrong-type-argument number-or-marker-p a)))) (ert-deftest comp-tests-gc () commit f867699b23ad012ad71f08f88ecf3e0e8df045da Author: Andrea Corallo Date: Mon Jun 10 10:33:25 2019 +0200 allow + in lisp functions to be compiled diff --git a/src/comp.c b/src/comp.c index 7de222b5b2..ede417c794 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1540,7 +1540,8 @@ DEFUN ("native-compile", Fnative_compile, Snative_compile, char *c = c_f_name; while (*c) { - if (*c == '-') + if (*c == '-' || + *c == '+') *c = '_'; ++c; } commit a5803441934b5a128f02169c37e4e00b25b4fc10 Author: Andrea Corallo Date: Mon Jun 10 10:08:03 2019 +0200 add speed parameter diff --git a/src/comp.c b/src/comp.c index 0098b81458..7de222b5b2 100644 --- a/src/comp.c +++ b/src/comp.c @@ -30,6 +30,8 @@ along with GNU Emacs. If not, see . */ #include "atimer.h" #include "window.h" +#define DEFAULT_SPEED 2 /* From 0 to 3 map to gcc -O */ + #define COMP_DEBUG 1 #define MAX_FUN_NAME 256 @@ -194,7 +196,7 @@ INLINE static void pop (unsigned n, gcc_jit_lvalue ***stack_ref, gcc_jit_rvalue *args[]); void emacs_native_compile (const char *lisp_f_name, const char *c_f_name, - Lisp_Object func, bool dump_asm); + Lisp_Object func, int opt_level, bool dump_asm); static void @@ -1461,7 +1463,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, void emacs_native_compile (const char *lisp_f_name, const char *c_f_name, - Lisp_Object func, bool dump_asm) + Lisp_Object func, int opt_level, bool dump_asm) { Lisp_Object bytestr = AREF (func, COMPILED_BYTECODE); CHECK_STRING (bytestr); @@ -1487,6 +1489,10 @@ emacs_native_compile (const char *lisp_f_name, const char *c_f_name, sigset_t oldset; block_atimers (&oldset); + gcc_jit_context_set_int_option (comp.ctxt, + GCC_JIT_INT_OPTION_OPTIMIZATION_LEVEL, + opt_level); + comp_f_res_t comp_res = compile_f (c_f_name, bytestr_length, SDATA (bytestr), XFIXNAT (maxdepth) + 1, vectorp, ASIZE (vector), @@ -1512,9 +1518,9 @@ emacs_native_compile (const char *lisp_f_name, const char *c_f_name, } DEFUN ("native-compile", Fnative_compile, Snative_compile, - 1, 2, 0, + 1, 3, 0, doc: /* Compile as native code function FUNC and load it. */) /* FIXME doc */ - (Lisp_Object func, Lisp_Object disassemble) + (Lisp_Object func, Lisp_Object speed, Lisp_Object disassemble) { static char c_f_name[MAX_FUN_NAME]; char *lisp_f_name; @@ -1543,7 +1549,20 @@ DEFUN ("native-compile", Fnative_compile, Snative_compile, if (!COMPILEDP (func)) error ("Not a byte-compiled function"); - emacs_native_compile (lisp_f_name, c_f_name, func, disassemble != Qnil); + if (speed != Qnil && + (!FIXNUMP (speed) || + !(XFIXNUM (speed) >= 0 && + XFIXNUM (speed) <= 3))) + error ("opt-level must be number between 0 and 3"); + + int opt_level; + if (speed == Qnil) + opt_level = DEFAULT_SPEED; + else + opt_level = XFIXNUM (speed); + + emacs_native_compile (lisp_f_name, c_f_name, func, opt_level, + disassemble != Qnil); if (disassemble) { commit 8bfe8ce8d0885e8022b2bea82d1cff9cbed86fb1 Author: Andrea Corallo Date: Sun Jun 9 17:01:06 2019 +0200 add sub1 diff --git a/src/comp.c b/src/comp.c index 63bf88870b..0098b81458 100644 --- a/src/comp.c +++ b/src/comp.c @@ -149,7 +149,9 @@ typedef struct { typedef struct { gcc_jit_context *ctxt; gcc_jit_type *void_type; + gcc_jit_type *bool_type; gcc_jit_type *int_type; + gcc_jit_type *unsigned_type; gcc_jit_type *long_type; gcc_jit_type *long_long_type; gcc_jit_type *void_ptr_type; @@ -157,6 +159,13 @@ typedef struct { gcc_jit_type *lisp_obj_type; gcc_jit_field *lisp_obj_as_ptr; gcc_jit_field *lisp_obj_as_num; + /* libgccjit has really limited support for casting therefore this union will + be used for the scope. */ + gcc_jit_type *cast_union_type; + gcc_jit_field *cast_union_as_ll; + gcc_jit_field *cast_union_as_u; + gcc_jit_field *cast_union_as_i; + gcc_jit_field *cast_union_as_b; gcc_jit_function *func; /* Current function being compiled */ gcc_jit_rvalue *scratch; /* Will point to scratch_call_area */ gcc_jit_rvalue *most_positive_fixnum; @@ -211,22 +220,118 @@ pop (unsigned n, gcc_jit_lvalue ***stack_ref, gcc_jit_rvalue *args[]) *stack_ref = stack; } +INLINE static gcc_jit_field * +type_to_cast_field (gcc_jit_type *type) +{ + gcc_jit_field *field; + + if (type == comp.long_long_type) + field = comp.cast_union_as_ll; + else if (type == comp.unsigned_type) + field = comp.cast_union_as_u; + else if (type == comp.int_type) + field = comp.cast_union_as_i; + else if (type == comp.bool_type) + field = comp.cast_union_as_b; + else + error ("unsopported cast\n"); + + return field; +} + +static gcc_jit_rvalue * +comp_cast (gcc_jit_type *new_type, gcc_jit_rvalue *obj) +{ + gcc_jit_field *orig_field = + type_to_cast_field (gcc_jit_rvalue_get_type (obj)); + gcc_jit_field *dest_field = type_to_cast_field (new_type); + + gcc_jit_lvalue *tmp_u = + gcc_jit_function_new_local (comp.func, + NULL, + comp.cast_union_type, + "union_cast"); + gcc_jit_block_add_assignment (comp.bblock->gcc_bb, + NULL, + gcc_jit_lvalue_access_field (tmp_u, + NULL, + orig_field), + obj); + + return gcc_jit_rvalue_access_field ( gcc_jit_lvalue_as_rvalue (tmp_u), + NULL, + dest_field); +} + INLINE static gcc_jit_rvalue * -comp_xfixnum (gcc_jit_rvalue *obj) +comp_XLI (gcc_jit_rvalue *obj) +{ + return gcc_jit_rvalue_access_field (obj, + NULL, + comp.lisp_obj_as_num); +} + +static gcc_jit_rvalue * +comp_FIXNUMP (gcc_jit_rvalue *obj) { - return gcc_jit_context_new_binary_op ( - comp.ctxt, - NULL, - GCC_JIT_BINARY_OP_RSHIFT, - comp.long_long_type, - gcc_jit_rvalue_access_field (obj, + /* (! (((unsigned) (XLI (x) >> (USE_LSB_TAG ? 0 : FIXNUM_BITS)) + - (unsigned) (Lisp_Int0 >> !USE_LSB_TAG)) + & ((1 << INTTYPEBITS) - 1))) */ + + gcc_jit_rvalue *sh_res = + gcc_jit_context_new_binary_op ( + comp.ctxt, + NULL, + GCC_JIT_BINARY_OP_RSHIFT, + comp.long_long_type, + comp_XLI (obj), + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.long_long_type, + (USE_LSB_TAG ? 0 : FIXNUM_BITS))); + + gcc_jit_rvalue *minus_res = + gcc_jit_context_new_binary_op (comp.ctxt, + NULL, + GCC_JIT_BINARY_OP_MINUS, + comp.unsigned_type, + comp_cast (comp.unsigned_type, sh_res), + gcc_jit_context_new_rvalue_from_int ( + comp.ctxt, + comp.unsigned_type, + (Lisp_Int0 >> !USE_LSB_TAG))); + + gcc_jit_rvalue *res = + gcc_jit_context_new_unary_op ( + comp.ctxt, + NULL, + GCC_JIT_UNARY_OP_LOGICAL_NEGATE, + comp.int_type, + gcc_jit_context_new_binary_op (comp.ctxt, + NULL, + GCC_JIT_BINARY_OP_BITWISE_AND, + comp.unsigned_type, + minus_res, + gcc_jit_context_new_rvalue_from_int ( + comp.ctxt, + comp.unsigned_type, + ((1 << INTTYPEBITS) - 1)))); + + return res; +} + +static gcc_jit_rvalue * +comp_XFIXNUM (gcc_jit_rvalue *obj) +{ + return gcc_jit_context_new_binary_op (comp.ctxt, NULL, - comp.lisp_obj_as_num), - comp.inttypebits); + GCC_JIT_BINARY_OP_RSHIFT, + comp.long_long_type, + comp_XLI (obj), + comp.inttypebits); } -INLINE static gcc_jit_rvalue * -comp_make_fixnum (gcc_jit_rvalue *obj) +static gcc_jit_rvalue * +comp_make_fixnum (gcc_jit_block *block, gcc_jit_rvalue *obj) { gcc_jit_rvalue *tmp = gcc_jit_context_new_binary_op (comp.ctxt, @@ -248,7 +353,7 @@ comp_make_fixnum (gcc_jit_rvalue *obj) comp.lisp_obj_type, "lisp_obj_fixnum"); - gcc_jit_block_add_assignment (comp.bblock->gcc_bb, + gcc_jit_block_add_assignment (block, NULL, gcc_jit_lvalue_access_field ( res, @@ -261,7 +366,7 @@ comp_make_fixnum (gcc_jit_rvalue *obj) /* Construct fill and return a lisp object form a raw pointer. */ -INLINE static gcc_jit_rvalue * +static gcc_jit_rvalue * comp_lisp_obj_as_ptr_from_ptr (basic_block_t *bblock, void *p) { gcc_jit_lvalue *lisp_obj = gcc_jit_function_new_local (comp.func, @@ -567,9 +672,8 @@ compute_bblocks (ptrdiff_t bytestr_length, unsigned char *bytestr_data) /* Close current basic block emitting a conditional. */ -static void -comp_emit_conditional (enum gcc_jit_comparison op, - gcc_jit_rvalue *test, +INLINE static void +comp_emit_cond_jump (gcc_jit_rvalue *test, gcc_jit_block *then_target, gcc_jit_block *else_target) { gcc_jit_block_end_with_conditional (comp.bblock->gcc_bb, @@ -583,16 +687,16 @@ comp_emit_conditional (enum gcc_jit_comparison op, /* Close current basic block emitting a comparison between two rval. */ static gcc_jit_rvalue * -comp_emit_comparison (enum gcc_jit_comparison op, - gcc_jit_rvalue *a, gcc_jit_rvalue *b, - gcc_jit_block *then_target, gcc_jit_block *else_target) +comp_emit_comp_jump (enum gcc_jit_comparison op, + gcc_jit_rvalue *a, gcc_jit_rvalue *b, + gcc_jit_block *then_target, gcc_jit_block *else_target) { gcc_jit_rvalue *test = gcc_jit_context_new_comparison (comp.ctxt, NULL, op, a, b); - comp_emit_conditional (op, test, then_target, else_target); + comp_emit_cond_jump (test, then_target, else_target); return test; } @@ -892,38 +996,60 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, case Bsub1: { - gcc_jit_block *sub1_inline = - gcc_jit_function_new_block (comp.func, "-1 inline"); - gcc_jit_block *sub1_fcall = - gcc_jit_function_new_block (comp.func, "-1 fcall"); + + /* (FIXNUMP (TOP) && XFIXNUM (TOP) != MOST_NEGATIVE_FIXNUM + ? make_fixnum (XFIXNUM (TOP) - 1) + : Fsub1 (TOP)) */ + + gcc_jit_block *sub1_inline_block = + gcc_jit_function_new_block (comp.func, "inline-1"); + gcc_jit_block *sub1_fcall_block = + gcc_jit_function_new_block (comp.func, "fcall-1"); gcc_jit_rvalue *tos_as_num = - gcc_jit_rvalue_access_field (gcc_jit_lvalue_as_rvalue (TOS), - NULL, - comp.lisp_obj_as_num); - comp_emit_comparison (GCC_JIT_COMPARISON_NE, - tos_as_num, - comp.most_negative_fixnum, - sub1_inline, sub1_fcall); + comp_XFIXNUM (gcc_jit_lvalue_as_rvalue (TOS)); + + comp_emit_cond_jump ( + gcc_jit_context_new_binary_op ( + comp.ctxt, + NULL, + GCC_JIT_BINARY_OP_LOGICAL_AND, + comp.bool_type, + comp_cast (comp.bool_type, + comp_FIXNUMP (gcc_jit_lvalue_as_rvalue (TOS))), + gcc_jit_context_new_comparison (comp.ctxt, + NULL, + GCC_JIT_COMPARISON_NE, + tos_as_num, + comp.most_negative_fixnum)), + sub1_inline_block, + sub1_fcall_block); + gcc_jit_rvalue *sub1_inline_res = gcc_jit_context_new_binary_op (comp.ctxt, NULL, GCC_JIT_BINARY_OP_MINUS, - comp.lisp_obj_type, + comp.long_long_type, tos_as_num, comp.one); - gcc_jit_block_add_assignment (sub1_inline, + + gcc_jit_block_add_assignment (sub1_inline_block, NULL, TOS, - sub1_inline_res); + comp_make_fixnum (sub1_inline_block, + sub1_inline_res)); + basic_block_t bb_orig = *comp.bblock; + + comp.bblock->gcc_bb = sub1_fcall_block; + POP1; + res = comp_emit_call ("Fsub1", comp.lisp_obj_type, 1, args); + PUSH_LVAL (res); - /* TODO fill sub1_fcall */ - /* comp.bblock->gcc_bb = sub1_fcall; */ - /* comp.bblock->terminated = false; */ + *comp.bblock = bb_orig; - gcc_jit_block_end_with_jump (sub1_inline, NULL, + gcc_jit_block_end_with_jump (sub1_inline_block, NULL, bb_map[pc].gcc_bb); - gcc_jit_block_end_with_jump (sub1_fcall, NULL, + gcc_jit_block_end_with_jump (sub1_fcall_block, NULL, bb_map[pc].gcc_bb); } @@ -1053,32 +1179,32 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, case Bgotoifnil: op = FETCH2; POP1; - comp_emit_comparison (GCC_JIT_COMPARISON_EQ, args[0], nil, - bb_map[op].gcc_bb, bb_map[pc].gcc_bb); + comp_emit_comp_jump (GCC_JIT_COMPARISON_EQ, args[0], nil, + bb_map[op].gcc_bb, bb_map[pc].gcc_bb); break; case Bgotoifnonnil: op = FETCH2; POP1; - comp_emit_comparison (GCC_JIT_COMPARISON_NE, args[0], nil, - bb_map[op].gcc_bb, bb_map[pc].gcc_bb); + comp_emit_comp_jump (GCC_JIT_COMPARISON_NE, args[0], nil, + bb_map[op].gcc_bb, bb_map[pc].gcc_bb); break; case Bgotoifnilelsepop: op = FETCH2; - comp_emit_comparison (GCC_JIT_COMPARISON_EQ, - gcc_jit_lvalue_as_rvalue (TOS), - nil, - bb_map[op].gcc_bb, bb_map[pc].gcc_bb); + comp_emit_comp_jump (GCC_JIT_COMPARISON_EQ, + gcc_jit_lvalue_as_rvalue (TOS), + nil, + bb_map[op].gcc_bb, bb_map[pc].gcc_bb); POP1; break; case Bgotoifnonnilelsepop: op = FETCH2; - comp_emit_comparison (GCC_JIT_COMPARISON_NE, - gcc_jit_lvalue_as_rvalue (TOS), - nil, - bb_map[op].gcc_bb, bb_map[pc].gcc_bb); + comp_emit_comp_jump (GCC_JIT_COMPARISON_NE, + gcc_jit_lvalue_as_rvalue (TOS), + nil, + bb_map[op].gcc_bb, bb_map[pc].gcc_bb); POP1; break; @@ -1239,35 +1365,35 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, op = FETCH - 128; op += pc; POP1; - comp_emit_comparison (GCC_JIT_COMPARISON_EQ, args[0], nil, - bb_map[op].gcc_bb, bb_map[pc].gcc_bb); + comp_emit_comp_jump (GCC_JIT_COMPARISON_EQ, args[0], nil, + bb_map[op].gcc_bb, bb_map[pc].gcc_bb); break; case BRgotoifnonnil: op = FETCH - 128; op += pc; POP1; - comp_emit_comparison (GCC_JIT_COMPARISON_NE, args[0], nil, - bb_map[op].gcc_bb, bb_map[pc].gcc_bb); + comp_emit_comp_jump (GCC_JIT_COMPARISON_NE, args[0], nil, + bb_map[op].gcc_bb, bb_map[pc].gcc_bb); break; case BRgotoifnilelsepop: op = FETCH - 128; op += pc; - comp_emit_comparison (GCC_JIT_COMPARISON_EQ, - gcc_jit_lvalue_as_rvalue (TOS), - nil, - bb_map[op].gcc_bb, bb_map[pc].gcc_bb); + comp_emit_comp_jump (GCC_JIT_COMPARISON_EQ, + gcc_jit_lvalue_as_rvalue (TOS), + nil, + bb_map[op].gcc_bb, bb_map[pc].gcc_bb); POP1; break; case BRgotoifnonnilelsepop: op = FETCH - 128; op += pc; - comp_emit_comparison (GCC_JIT_COMPARISON_NE, - gcc_jit_lvalue_as_rvalue (TOS), - nil, - bb_map[op].gcc_bb, bb_map[pc].gcc_bb); + comp_emit_comp_jump (GCC_JIT_COMPARISON_NE, + gcc_jit_lvalue_as_rvalue (TOS), + nil, + bb_map[op].gcc_bb, bb_map[pc].gcc_bb); POP1; break; @@ -1464,6 +1590,9 @@ init_comp (void) comp.void_ptr_type = gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_VOID_PTR); comp.int_type = gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_INT); + comp.unsigned_type = gcc_jit_context_get_type (comp.ctxt, + GCC_JIT_TYPE_UNSIGNED_INT); + comp.bool_type = gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_BOOL); comp.long_type = gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_LONG); comp.long_long_type = gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_LONG_LONG); @@ -1498,6 +1627,38 @@ init_comp (void) "LispObj", 2, lisp_obj_fields); + + comp.cast_union_as_ll = + gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.long_long_type, /* FIXME? */ + "ll"); + comp.cast_union_as_u = + gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.unsigned_type, + "u"); + comp.cast_union_as_i = + gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.int_type, + "i"); + comp.cast_union_as_b = + gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.bool_type, + "b"); + + gcc_jit_field *cast_union_fields[4] = + { comp.cast_union_as_ll, + comp.cast_union_as_u, + comp.cast_union_as_i, + comp.cast_union_as_b,}; + comp.cast_union_type = gcc_jit_context_new_union_type (comp.ctxt, + NULL, + "cast_union", + 4, + cast_union_fields); comp.most_positive_fixnum = gcc_jit_context_new_rvalue_from_long (comp.ctxt, comp.long_long_type, /* FIXME? */ diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index e1d6f313fd..e13db89ddc 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -146,6 +146,22 @@ (should (= (comp-tests-conditionals-2-f t) 1340)) (should (eq (comp-tests-conditionals-2-f nil) nil))) +(ert-deftest comp-tests-fixnum () + "Testing some fixnum inline operation." + (defun comp-tests-fixnum-1-f (x) + (1- x)) + + (byte-compile #'comp-tests-fixnum-1-f) + (native-compile #'comp-tests-fixnum-1-f) + + (should (= (comp-tests-fixnum-1-f 10) 9)) + (should (= (comp-tests-fixnum-1-f most-negative-fixnum) + (1- most-negative-fixnum))) + (should (equal (condition-case err + (comp-tests-fixnum-1-f 'a) + (error (print err))) + '(wrong-type-argument number-or-marker-p a)))) + (ert-deftest comp-tests-gc () "Try to do some longer computation to let the gc kick in." (dotimes (_ 100000) commit 96fc40d7dbdc77efa7b2e01f231bef9e19e96786 Author: Andrea Corallo Date: Sun Jun 9 16:59:34 2019 +0200 generate reproducer if needed diff --git a/src/comp.c b/src/comp.c index 12d952ca2a..63bf88870b 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1457,6 +1457,9 @@ init_comp (void) { comp.ctxt = gcc_jit_context_acquire(); + if (COMP_DEBUG > 1) + gcc_jit_context_dump_reproducer_to_file (comp.ctxt, "comp_reproducer.c"); + comp.void_type = gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_VOID); comp.void_ptr_type = gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_VOID_PTR); commit efd20b8c4bec0b6edfeb0c415719cb7b230496ba Author: Andrea Corallo Date: Sun Jun 9 16:58:54 2019 +0200 add comp_xfixnum + comp_make_fixnum diff --git a/src/comp.c b/src/comp.c index 44d9a783f0..12d952ca2a 100644 --- a/src/comp.c +++ b/src/comp.c @@ -162,6 +162,8 @@ typedef struct { gcc_jit_rvalue *most_positive_fixnum; gcc_jit_rvalue *most_negative_fixnum; gcc_jit_rvalue *one; + gcc_jit_rvalue *inttypebits; + gcc_jit_rvalue *lisp_int0; basic_block_t *bblock; /* Current basic block */ Lisp_Object func_hash; /* f_name -> gcc_func */ } comp_t; @@ -209,6 +211,54 @@ pop (unsigned n, gcc_jit_lvalue ***stack_ref, gcc_jit_rvalue *args[]) *stack_ref = stack; } +INLINE static gcc_jit_rvalue * +comp_xfixnum (gcc_jit_rvalue *obj) +{ + return gcc_jit_context_new_binary_op ( + comp.ctxt, + NULL, + GCC_JIT_BINARY_OP_RSHIFT, + comp.long_long_type, + gcc_jit_rvalue_access_field (obj, + NULL, + comp.lisp_obj_as_num), + comp.inttypebits); +} + +INLINE static gcc_jit_rvalue * +comp_make_fixnum (gcc_jit_rvalue *obj) +{ + gcc_jit_rvalue *tmp = + gcc_jit_context_new_binary_op (comp.ctxt, + NULL, + GCC_JIT_BINARY_OP_LSHIFT, + comp.long_long_type, + obj, + comp.inttypebits); + + tmp = gcc_jit_context_new_binary_op (comp.ctxt, + NULL, + GCC_JIT_BINARY_OP_PLUS, + comp.long_long_type, + tmp, + comp.lisp_int0); + + gcc_jit_lvalue *res = gcc_jit_function_new_local (comp.func, + NULL, + comp.lisp_obj_type, + "lisp_obj_fixnum"); + + gcc_jit_block_add_assignment (comp.bblock->gcc_bb, + NULL, + gcc_jit_lvalue_access_field ( + res, + NULL, + comp.lisp_obj_as_num), + tmp); + + return gcc_jit_lvalue_as_rvalue (res); +} + /* Construct fill and return a lisp object form a raw pointer. */ INLINE static gcc_jit_rvalue * @@ -217,7 +267,7 @@ comp_lisp_obj_as_ptr_from_ptr (basic_block_t *bblock, void *p) gcc_jit_lvalue *lisp_obj = gcc_jit_function_new_local (comp.func, NULL, comp.lisp_obj_type, - "lisp_obj"); + "lisp_obj_from_ptr"); gcc_jit_lvalue *lisp_obj_as_ptr = gcc_jit_lvalue_access_field (lisp_obj, NULL, @@ -1457,6 +1507,15 @@ init_comp (void) gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.long_long_type, /* FIXME? */ 1); + comp.inttypebits = + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.long_long_type, /* FIXME? */ + INTTYPEBITS); + + comp.lisp_int0 = + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.long_long_type, /* FIXME? */ + Lisp_Int0); enum gcc_jit_types ptrdiff_t_gcc; if (sizeof (ptrdiff_t) == sizeof (int)) commit 34d1a15307a4cb1f667e8af6ecca523369c436c1 Author: Andrea Corallo Date: Sat Jun 8 17:24:47 2019 +0200 fix uninitialized read diff --git a/src/comp.c b/src/comp.c index e46cd5cfec..44d9a783f0 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1355,9 +1355,13 @@ DEFUN ("native-compile", Fnative_compile, Snative_compile, /* FIXME how many other characters are not allowed in C? This will introduce name clashs too. */ - for (int i; i < strlen(c_f_name); i++) - if (c_f_name[i] == '-') - c_f_name[i] = '_'; + char *c = c_f_name; + while (*c) + { + if (*c == '-') + *c = '_'; + ++c; + } func = indirect_function (func); if (!COMPILEDP (func)) commit 1e9bd1df4c1def12750b2ce6dc335c1921a21686 Author: Andrea Corallo Date: Sat Jun 8 17:24:29 2019 +0200 adding sub1 diff --git a/src/comp.c b/src/comp.c index c675095cec..e46cd5cfec 100644 --- a/src/comp.c +++ b/src/comp.c @@ -475,7 +475,7 @@ compute_bblocks (ptrdiff_t bytestr_length, unsigned char *bytestr_data) bb_start_pc[bb_n++] = op; new_bb = true; break; - /* Return */ + case Bsub1: case Breturn: new_bb = true; break; @@ -517,21 +517,32 @@ compute_bblocks (ptrdiff_t bytestr_length, unsigned char *bytestr_data) /* Close current basic block emitting a conditional. */ -static gcc_jit_rvalue * +static void comp_emit_conditional (enum gcc_jit_comparison op, - gcc_jit_rvalue *a, gcc_jit_rvalue *b, + gcc_jit_rvalue *test, gcc_jit_block *then_target, gcc_jit_block *else_target) { - gcc_jit_rvalue *test = gcc_jit_context_new_comparison (comp.ctxt, - NULL, - op, - a, b); gcc_jit_block_end_with_conditional (comp.bblock->gcc_bb, NULL, test, then_target, else_target); comp.bblock->terminated = true; +} + +/* Close current basic block emitting a comparison between two rval. */ + +static gcc_jit_rvalue * +comp_emit_comparison (enum gcc_jit_comparison op, + gcc_jit_rvalue *a, gcc_jit_rvalue *b, + gcc_jit_block *then_target, gcc_jit_block *else_target) +{ + gcc_jit_rvalue *test = gcc_jit_context_new_comparison (comp.ctxt, + NULL, + op, + a, b); + + comp_emit_conditional (op, test, then_target, else_target); return test; } @@ -830,7 +841,42 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, break; case Bsub1: - error ("Bsub1 unsupported bytecode\n"); + { + gcc_jit_block *sub1_inline = + gcc_jit_function_new_block (comp.func, "-1 inline"); + gcc_jit_block *sub1_fcall = + gcc_jit_function_new_block (comp.func, "-1 fcall"); + + gcc_jit_rvalue *tos_as_num = + gcc_jit_rvalue_access_field (gcc_jit_lvalue_as_rvalue (TOS), + NULL, + comp.lisp_obj_as_num); + comp_emit_comparison (GCC_JIT_COMPARISON_NE, + tos_as_num, + comp.most_negative_fixnum, + sub1_inline, sub1_fcall); + gcc_jit_rvalue *sub1_inline_res = + gcc_jit_context_new_binary_op (comp.ctxt, + NULL, + GCC_JIT_BINARY_OP_MINUS, + comp.lisp_obj_type, + tos_as_num, + comp.one); + gcc_jit_block_add_assignment (sub1_inline, + NULL, + TOS, + sub1_inline_res); + + /* TODO fill sub1_fcall */ + /* comp.bblock->gcc_bb = sub1_fcall; */ + /* comp.bblock->terminated = false; */ + + gcc_jit_block_end_with_jump (sub1_inline, NULL, + bb_map[pc].gcc_bb); + gcc_jit_block_end_with_jump (sub1_fcall, NULL, + bb_map[pc].gcc_bb); + } + break; case Badd1: error ("Badd1 unsupported bytecode\n"); @@ -957,32 +1003,32 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, case Bgotoifnil: op = FETCH2; POP1; - comp_emit_conditional (GCC_JIT_COMPARISON_EQ, args[0], nil, - bb_map[op].gcc_bb, bb_map[pc].gcc_bb); + comp_emit_comparison (GCC_JIT_COMPARISON_EQ, args[0], nil, + bb_map[op].gcc_bb, bb_map[pc].gcc_bb); break; case Bgotoifnonnil: op = FETCH2; POP1; - comp_emit_conditional (GCC_JIT_COMPARISON_NE, args[0], nil, - bb_map[op].gcc_bb, bb_map[pc].gcc_bb); + comp_emit_comparison (GCC_JIT_COMPARISON_NE, args[0], nil, + bb_map[op].gcc_bb, bb_map[pc].gcc_bb); break; case Bgotoifnilelsepop: op = FETCH2; - comp_emit_conditional (GCC_JIT_COMPARISON_EQ, - gcc_jit_lvalue_as_rvalue (TOS), - nil, - bb_map[op].gcc_bb, bb_map[pc].gcc_bb); + comp_emit_comparison (GCC_JIT_COMPARISON_EQ, + gcc_jit_lvalue_as_rvalue (TOS), + nil, + bb_map[op].gcc_bb, bb_map[pc].gcc_bb); POP1; break; case Bgotoifnonnilelsepop: op = FETCH2; - comp_emit_conditional (GCC_JIT_COMPARISON_NE, - gcc_jit_lvalue_as_rvalue (TOS), - nil, - bb_map[op].gcc_bb, bb_map[pc].gcc_bb); + comp_emit_comparison (GCC_JIT_COMPARISON_NE, + gcc_jit_lvalue_as_rvalue (TOS), + nil, + bb_map[op].gcc_bb, bb_map[pc].gcc_bb); POP1; break; @@ -1143,35 +1189,35 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, op = FETCH - 128; op += pc; POP1; - comp_emit_conditional (GCC_JIT_COMPARISON_EQ, args[0], nil, - bb_map[op].gcc_bb, bb_map[pc].gcc_bb); + comp_emit_comparison (GCC_JIT_COMPARISON_EQ, args[0], nil, + bb_map[op].gcc_bb, bb_map[pc].gcc_bb); break; case BRgotoifnonnil: op = FETCH - 128; op += pc; POP1; - comp_emit_conditional (GCC_JIT_COMPARISON_NE, args[0], nil, - bb_map[op].gcc_bb, bb_map[pc].gcc_bb); + comp_emit_comparison (GCC_JIT_COMPARISON_NE, args[0], nil, + bb_map[op].gcc_bb, bb_map[pc].gcc_bb); break; case BRgotoifnilelsepop: op = FETCH - 128; op += pc; - comp_emit_conditional (GCC_JIT_COMPARISON_EQ, - gcc_jit_lvalue_as_rvalue (TOS), - nil, - bb_map[op].gcc_bb, bb_map[pc].gcc_bb); + comp_emit_comparison (GCC_JIT_COMPARISON_EQ, + gcc_jit_lvalue_as_rvalue (TOS), + nil, + bb_map[op].gcc_bb, bb_map[pc].gcc_bb); POP1; break; case BRgotoifnonnilelsepop: op = FETCH - 128; op += pc; - comp_emit_conditional (GCC_JIT_COMPARISON_NE, - gcc_jit_lvalue_as_rvalue (TOS), - nil, - bb_map[op].gcc_bb, bb_map[pc].gcc_bb); + comp_emit_comparison (GCC_JIT_COMPARISON_NE, + gcc_jit_lvalue_as_rvalue (TOS), + nil, + bb_map[op].gcc_bb, bb_map[pc].gcc_bb); POP1; break; @@ -1397,15 +1443,15 @@ init_comp (void) lisp_obj_fields); comp.most_positive_fixnum = gcc_jit_context_new_rvalue_from_long (comp.ctxt, - comp.long_type, /* FIXME? */ + comp.long_long_type, /* FIXME? */ MOST_POSITIVE_FIXNUM); comp.most_negative_fixnum = gcc_jit_context_new_rvalue_from_long (comp.ctxt, - comp.long_type, /* FIXME? */ + comp.long_long_type, /* FIXME? */ MOST_NEGATIVE_FIXNUM); comp.one = gcc_jit_context_new_rvalue_from_int (comp.ctxt, - comp.int_type, + comp.long_long_type, /* FIXME? */ 1); enum gcc_jit_types ptrdiff_t_gcc; commit e642113184136a66fee782c3cdec832ec2ba4c0b Author: Andrea Corallo Date: Sat Jun 8 16:00:24 2019 +0200 remame compiler functions diff --git a/src/comp.c b/src/comp.c index ddc0bd067f..c675095cec 100644 --- a/src/comp.c +++ b/src/comp.c @@ -40,7 +40,7 @@ along with GNU Emacs. If not, see . */ #define DISASS_FILE_NAME "emacs-asm.s" -#define CHECK_STACK \ +#define CHECK_STACK \ eassert (stack >= stack_base && stack < stack_over) #define PUSH_LVAL(obj) \ @@ -125,7 +125,7 @@ along with GNU Emacs. If not, see . */ #define CASE_CALL_NARGS(name, nargs) \ case B##name: \ POP##nargs; \ - res = gcc_emit_call (STR(F##name), comp.lisp_obj_type, nargs, args); \ + res = comp_emit_call (STR(F##name), comp.lisp_obj_type, nargs, args); \ PUSH_LVAL (res); \ break @@ -135,7 +135,7 @@ along with GNU Emacs. If not, see . */ #define EMIT_SCRATCH_CALL_N(name, nargs) \ do { \ pop (nargs, &stack, args); \ - res = gcc_emit_callN (name, nargs, args); \ + res = comp_emit_callN (name, nargs, args); \ PUSH_LVAL (res); \ } while (0) @@ -193,7 +193,7 @@ bcall0 (Lisp_Object f) } /* Pop form the main evaluation stack and place the elements in args in reversed - order. */ + order. */ INLINE static void pop (unsigned n, gcc_jit_lvalue ***stack_ref, gcc_jit_rvalue *args[]) @@ -212,11 +212,11 @@ pop (unsigned n, gcc_jit_lvalue ***stack_ref, gcc_jit_rvalue *args[]) /* Construct fill and return a lisp object form a raw pointer. */ INLINE static gcc_jit_rvalue * -gcc_lisp_obj_as_ptr_from_ptr (basic_block_t *bblock, void *p) +comp_lisp_obj_as_ptr_from_ptr (basic_block_t *bblock, void *p) { gcc_jit_lvalue *lisp_obj = gcc_jit_function_new_local (comp.func, - NULL, - comp.lisp_obj_type, + NULL, + comp.lisp_obj_type, "lisp_obj"); gcc_jit_lvalue *lisp_obj_as_ptr = gcc_jit_lvalue_access_field (lisp_obj, @@ -236,9 +236,9 @@ gcc_lisp_obj_as_ptr_from_ptr (basic_block_t *bblock, void *p) } static gcc_jit_function * -gcc_func_declare (const char *f_name, gcc_jit_type *ret_type, - unsigned nargs, gcc_jit_rvalue **args, - enum gcc_jit_function_kind kind, bool reusable) +comp_func_declare (const char *f_name, gcc_jit_type *ret_type, + unsigned nargs, gcc_jit_rvalue **args, + enum gcc_jit_function_kind kind, bool reusable) { gcc_jit_param *param[4]; gcc_jit_type *type[4]; @@ -315,8 +315,8 @@ gcc_func_declare (const char *f_name, gcc_jit_type *ret_type, } static gcc_jit_lvalue * -gcc_emit_call (const char *f_name, gcc_jit_type *ret_type, unsigned nargs, - gcc_jit_rvalue **args) +comp_emit_call (const char *f_name, gcc_jit_type *ret_type, unsigned nargs, + gcc_jit_rvalue **args) { Lisp_Object key = make_string (f_name, strlen (f_name)); EMACS_UINT hash = 0; @@ -325,8 +325,8 @@ gcc_emit_call (const char *f_name, gcc_jit_type *ret_type, unsigned nargs, if (i == -1) { - gcc_func_declare(f_name, ret_type, nargs, args, GCC_JIT_FUNCTION_IMPORTED, - true); + comp_func_declare(f_name, ret_type, nargs, args, GCC_JIT_FUNCTION_IMPORTED, + true); i = hash_lookup (ht, key, &hash); eassert (i != -1); } @@ -349,21 +349,21 @@ gcc_emit_call (const char *f_name, gcc_jit_type *ret_type, unsigned nargs, } static gcc_jit_lvalue * -gcc_emit_callN (const char *f_name, unsigned nargs, gcc_jit_rvalue **args) +comp_emit_callN (const char *f_name, unsigned nargs, gcc_jit_rvalue **args) { /* Here we set all the pointers into the scratch call area. */ /* TODO: distinguish primitives for faster calling convention. */ /* - Lisp_Object *p; - p = scratch_call_area; - - p[0] = nargs; - p[1] = 0x...; - . - . - . - p[n] = 0x...; + Lisp_Object *p; + p = scratch_call_area; + + p[0] = nargs; + p[1] = 0x...; + . + . + . + p[n] = 0x...; */ gcc_jit_lvalue *p = @@ -395,7 +395,7 @@ gcc_emit_callN (const char *f_name, unsigned nargs, gcc_jit_rvalue **args) nargs); args[1] = comp.scratch; - return gcc_emit_call (f_name, comp.lisp_obj_type, 2, args); + return comp_emit_call (f_name, comp.lisp_obj_type, 2, args); } static int @@ -518,9 +518,9 @@ compute_bblocks (ptrdiff_t bytestr_length, unsigned char *bytestr_data) /* Close current basic block emitting a conditional. */ static gcc_jit_rvalue * -gcc_emit_conditional (enum gcc_jit_comparison op, - gcc_jit_rvalue *a, gcc_jit_rvalue *b, - gcc_jit_block *then_target, gcc_jit_block *else_target) +comp_emit_conditional (enum gcc_jit_comparison op, + gcc_jit_rvalue *a, gcc_jit_rvalue *b, + gcc_jit_block *then_target, gcc_jit_block *else_target) { gcc_jit_rvalue *test = gcc_jit_context_new_comparison (comp.ctxt, NULL, @@ -578,8 +578,8 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, /* Current function being compiled. */ - comp.func = gcc_func_declare (f_name, comp.lisp_obj_type, comp_res.max_args, - NULL, GCC_JIT_FUNCTION_EXPORTED, false); + comp.func = comp_func_declare (f_name, comp.lisp_obj_type, comp_res.max_args, + NULL, GCC_JIT_FUNCTION_EXPORTED, false); char local_name[256]; for (int i = 0; i < stack_depth; ++i) @@ -596,7 +596,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, for (ptrdiff_t i = 0; i < comp_res.max_args; ++i) PUSH_PARAM (gcc_jit_function_get_param (comp.func, i)); - gcc_jit_rvalue *nil = gcc_lisp_obj_as_ptr_from_ptr (&bb_map[0], Qnil); + gcc_jit_rvalue *nil = comp_lisp_obj_as_ptr_from_ptr (&bb_map[0], Qnil); comp.bblock = NULL; @@ -652,8 +652,8 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, op = FETCH; varref: { - args[0] = gcc_lisp_obj_as_ptr_from_ptr (comp.bblock, vectorp[op]); - res = gcc_emit_call ("Fsymbol_value", comp.lisp_obj_type, 1, args); + args[0] = comp_lisp_obj_as_ptr_from_ptr (comp.bblock, vectorp[op]); + res = comp_emit_call ("Fsymbol_value", comp.lisp_obj_type, 1, args); PUSH_LVAL (res); break; } @@ -677,12 +677,12 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, { POP1; args[1] = args[0]; - args[0] = gcc_lisp_obj_as_ptr_from_ptr (comp.bblock, vectorp[op]); + args[0] = comp_lisp_obj_as_ptr_from_ptr (comp.bblock, vectorp[op]); args[2] = nil; args[3] = gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.int_type, SET_INTERNAL_SET); - res = gcc_emit_call ("set_internal", comp.lisp_obj_type, 4, args); + res = comp_emit_call ("set_internal", comp.lisp_obj_type, 4, args); PUSH_LVAL (res); } break; @@ -704,9 +704,9 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, op -= Bvarbind; varbind: { - args[0] = gcc_lisp_obj_as_ptr_from_ptr (comp.bblock, vectorp[op]); + args[0] = comp_lisp_obj_as_ptr_from_ptr (comp.bblock, vectorp[op]); pop (1, &stack, &args[1]); - res = gcc_emit_call ("specbind", comp.lisp_obj_type, 2, args); + res = comp_emit_call ("specbind", comp.lisp_obj_type, 2, args); PUSH_LVAL (res); break; } @@ -730,7 +730,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, { ptrdiff_t nargs = op + 1; pop (nargs, &stack, args); - res = gcc_emit_callN ("Ffuncall", nargs, args); + res = comp_emit_callN ("Ffuncall", nargs, args); PUSH_LVAL (res); break; } @@ -756,7 +756,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, comp.ptrdiff_type, op); - gcc_emit_call ("helper_unbind_n", comp.lisp_obj_type, 1, args); + comp_emit_call ("helper_unbind_n", comp.lisp_obj_type, 1, args); } break; case Bpophandler: @@ -794,12 +794,12 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, { POP1; args[1] = nil; - res = gcc_emit_call ("Fcons", comp.lisp_obj_type, 2, args); + res = comp_emit_call ("Fcons", comp.lisp_obj_type, 2, args); PUSH_LVAL (res); for (int i = 0; i < op; ++i) { POP2; - res = gcc_emit_call ("Fcons", comp.lisp_obj_type, 2, args); + res = comp_emit_call ("Fcons", comp.lisp_obj_type, 2, args); PUSH_LVAL (res); } break; @@ -889,7 +889,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, CASE_CALL_NARGS (following_char, 0); case Bpreceding_char: - res = gcc_emit_call ("Fprevious_char", comp.lisp_obj_type, 0, args); + res = comp_emit_call ("Fprevious_char", comp.lisp_obj_type, 0, args); PUSH_LVAL (res); break; @@ -898,7 +898,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, case Bindent_to: POP1; args[1] = nil; - res = gcc_emit_call ("Findent_to", comp.lisp_obj_type, 2, args); + res = comp_emit_call ("Findent_to", comp.lisp_obj_type, 2, args); PUSH_LVAL (res); break; @@ -919,14 +919,14 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, case Bsave_current_buffer: /* Obsolete since ??. */ case Bsave_current_buffer_1: - gcc_emit_call ("record_unwind_current_buffer", - comp.void_type, 0, NULL); + comp_emit_call ("record_unwind_current_buffer", + comp.void_type, 0, NULL); break; case Binteractive_p: /* Obsolete since 24.1. */ - PUSH_RVAL (gcc_lisp_obj_as_ptr_from_ptr (comp.bblock, - intern ("interactive-p"))); - res = gcc_emit_call ("call0", comp.lisp_obj_type, 1, args); + PUSH_RVAL (comp_lisp_obj_as_ptr_from_ptr (comp.bblock, + intern ("interactive-p"))); + res = comp_emit_call ("call0", comp.lisp_obj_type, 1, args); PUSH_LVAL (res); break; @@ -957,32 +957,32 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, case Bgotoifnil: op = FETCH2; POP1; - gcc_emit_conditional (GCC_JIT_COMPARISON_EQ, args[0], nil, - bb_map[op].gcc_bb, bb_map[pc].gcc_bb); + comp_emit_conditional (GCC_JIT_COMPARISON_EQ, args[0], nil, + bb_map[op].gcc_bb, bb_map[pc].gcc_bb); break; case Bgotoifnonnil: op = FETCH2; POP1; - gcc_emit_conditional (GCC_JIT_COMPARISON_NE, args[0], nil, - bb_map[op].gcc_bb, bb_map[pc].gcc_bb); + comp_emit_conditional (GCC_JIT_COMPARISON_NE, args[0], nil, + bb_map[op].gcc_bb, bb_map[pc].gcc_bb); break; case Bgotoifnilelsepop: op = FETCH2; - gcc_emit_conditional (GCC_JIT_COMPARISON_EQ, - gcc_jit_lvalue_as_rvalue (TOS), - nil, - bb_map[op].gcc_bb, bb_map[pc].gcc_bb); + comp_emit_conditional (GCC_JIT_COMPARISON_EQ, + gcc_jit_lvalue_as_rvalue (TOS), + nil, + bb_map[op].gcc_bb, bb_map[pc].gcc_bb); POP1; break; case Bgotoifnonnilelsepop: op = FETCH2; - gcc_emit_conditional (GCC_JIT_COMPARISON_NE, - gcc_jit_lvalue_as_rvalue (TOS), - nil, - bb_map[op].gcc_bb, bb_map[pc].gcc_bb); + comp_emit_conditional (GCC_JIT_COMPARISON_NE, + gcc_jit_lvalue_as_rvalue (TOS), + nil, + bb_map[op].gcc_bb, bb_map[pc].gcc_bb); POP1; break; @@ -1003,59 +1003,59 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, break; case Bsave_excursion: - res = gcc_emit_call ("record_unwind_protect_excursion", - comp.void_type, 0, args); + res = comp_emit_call ("record_unwind_protect_excursion", + comp.void_type, 0, args); break; case Bsave_window_excursion: /* Obsolete since 24.1. */ POP1; - res = gcc_emit_call ("helper_save_window_excursion", - comp.lisp_obj_type, 1, args); + res = comp_emit_call ("helper_save_window_excursion", + comp.lisp_obj_type, 1, args); PUSH_LVAL (res); break; case Bsave_restriction: - args[0] = gcc_lisp_obj_as_ptr_from_ptr (comp.bblock, - save_restriction_restore); + args[0] = comp_lisp_obj_as_ptr_from_ptr (comp.bblock, + save_restriction_restore); args[1] = - gcc_jit_lvalue_as_rvalue (gcc_emit_call ("save_restriction_save", - comp.lisp_obj_type, - 0, - NULL)); - gcc_emit_call ("record_unwind_protect", comp.void_ptr_type, 2, args); + gcc_jit_lvalue_as_rvalue (comp_emit_call ("save_restriction_save", + comp.lisp_obj_type, + 0, + NULL)); + comp_emit_call ("record_unwind_protect", comp.void_ptr_type, 2, args); break; case Bcatch: /* Obsolete since 24.4. */ POP2; args[2] = args[1]; - args[1] = gcc_lisp_obj_as_ptr_from_ptr (comp.bblock, eval_sub); - gcc_emit_call ("internal_catch", comp.void_ptr_type, 3, args); + args[1] = comp_lisp_obj_as_ptr_from_ptr (comp.bblock, eval_sub); + comp_emit_call ("internal_catch", comp.void_ptr_type, 3, args); break; case Bunwind_protect: /* FIXME: avoid closure for lexbind. */ POP1; - gcc_emit_call ("helper_unwind_protect", comp.void_type, 1, args); + comp_emit_call ("helper_unwind_protect", comp.void_type, 1, args); break; case Bcondition_case: /* Obsolete since 24.4. */ POP3; - gcc_emit_call ("internal_lisp_condition_case", - comp.lisp_obj_type, 3, args); + comp_emit_call ("internal_lisp_condition_case", + comp.lisp_obj_type, 3, args); break; case Btemp_output_buffer_setup: /* Obsolete since 24.1. */ POP1; - res = gcc_emit_call ("helper_temp_output_buffer_setup", comp.lisp_obj_type, - 1, args); + res = comp_emit_call ("helper_temp_output_buffer_setup", comp.lisp_obj_type, + 1, args); PUSH_LVAL (res); break; case Btemp_output_buffer_show: /* Obsolete since 24.1. */ POP2; - gcc_emit_call ("temp_output_buffer_show", comp.void_type, 1, - &args[1]); + comp_emit_call ("temp_output_buffer_show", comp.void_type, 1, + &args[1]); PUSH_RVAL (args[0]); - gcc_emit_call ("helper_unbind_n", comp.lisp_obj_type, 1, args); + comp_emit_call ("helper_unbind_n", comp.lisp_obj_type, 1, args); break; case Bunbind_all: /* Obsolete. Never used. */ @@ -1143,35 +1143,35 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, op = FETCH - 128; op += pc; POP1; - gcc_emit_conditional (GCC_JIT_COMPARISON_EQ, args[0], nil, - bb_map[op].gcc_bb, bb_map[pc].gcc_bb); + comp_emit_conditional (GCC_JIT_COMPARISON_EQ, args[0], nil, + bb_map[op].gcc_bb, bb_map[pc].gcc_bb); break; case BRgotoifnonnil: op = FETCH - 128; op += pc; POP1; - gcc_emit_conditional (GCC_JIT_COMPARISON_NE, args[0], nil, - bb_map[op].gcc_bb, bb_map[pc].gcc_bb); + comp_emit_conditional (GCC_JIT_COMPARISON_NE, args[0], nil, + bb_map[op].gcc_bb, bb_map[pc].gcc_bb); break; case BRgotoifnilelsepop: op = FETCH - 128; op += pc; - gcc_emit_conditional (GCC_JIT_COMPARISON_EQ, - gcc_jit_lvalue_as_rvalue (TOS), - nil, - bb_map[op].gcc_bb, bb_map[pc].gcc_bb); + comp_emit_conditional (GCC_JIT_COMPARISON_EQ, + gcc_jit_lvalue_as_rvalue (TOS), + nil, + bb_map[op].gcc_bb, bb_map[pc].gcc_bb); POP1; break; case BRgotoifnonnilelsepop: op = FETCH - 128; op += pc; - gcc_emit_conditional (GCC_JIT_COMPARISON_NE, - gcc_jit_lvalue_as_rvalue (TOS), - nil, - bb_map[op].gcc_bb, bb_map[pc].gcc_bb); + comp_emit_conditional (GCC_JIT_COMPARISON_NE, + gcc_jit_lvalue_as_rvalue (TOS), + nil, + bb_map[op].gcc_bb, bb_map[pc].gcc_bb); POP1; break; @@ -1209,7 +1209,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, if (pc >= bytestr_length || bytestr_data[pc] != Bswitch) { gcc_jit_rvalue *c = - gcc_lisp_obj_as_ptr_from_ptr (comp.bblock, vectorp[op]); + comp_lisp_obj_as_ptr_from_ptr (comp.bblock, vectorp[op]); PUSH_RVAL (c); /* Fprint(vectorp[op], Qnil); */ break; @@ -1422,11 +1422,11 @@ init_comp (void) comp.scratch = gcc_jit_lvalue_get_address( - gcc_jit_context_new_global (comp.ctxt, NULL, - GCC_JIT_GLOBAL_IMPORTED, - comp.lisp_obj_type, - "scratch_call_area"), - NULL); + gcc_jit_context_new_global (comp.ctxt, NULL, + GCC_JIT_GLOBAL_IMPORTED, + comp.lisp_obj_type, + "scratch_call_area"), + NULL); comp.func_hash = CALLN (Fmake_hash_table, QCtest, Qequal, QCweakness, Qt); commit b8aeb2e35d99e14970d15561fcf161ce78fd2426 Author: Andrea Corallo Date: Sat Jun 8 15:45:27 2019 +0200 move to lispobj as union diff --git a/src/comp.c b/src/comp.c index 8a88e5819c..ddc0bd067f 100644 --- a/src/comp.c +++ b/src/comp.c @@ -151,11 +151,13 @@ typedef struct { gcc_jit_type *void_type; gcc_jit_type *int_type; gcc_jit_type *long_type; + gcc_jit_type *long_long_type; gcc_jit_type *void_ptr_type; gcc_jit_type *ptrdiff_type; gcc_jit_type *lisp_obj_type; + gcc_jit_field *lisp_obj_as_ptr; + gcc_jit_field *lisp_obj_as_num; gcc_jit_function *func; /* Current function being compiled */ - gcc_jit_rvalue *nil; gcc_jit_rvalue *scratch; /* Will point to scratch_call_area */ gcc_jit_rvalue *most_positive_fixnum; gcc_jit_rvalue *most_negative_fixnum; @@ -207,6 +209,32 @@ pop (unsigned n, gcc_jit_lvalue ***stack_ref, gcc_jit_rvalue *args[]) *stack_ref = stack; } +/* Construct fill and return a lisp object form a raw pointer. */ + +INLINE static gcc_jit_rvalue * +gcc_lisp_obj_as_ptr_from_ptr (basic_block_t *bblock, void *p) +{ + gcc_jit_lvalue *lisp_obj = gcc_jit_function_new_local (comp.func, + NULL, + comp.lisp_obj_type, + "lisp_obj"); + gcc_jit_lvalue *lisp_obj_as_ptr = + gcc_jit_lvalue_access_field (lisp_obj, + NULL, + comp.lisp_obj_as_ptr); + + gcc_jit_rvalue *void_ptr = + gcc_jit_context_new_rvalue_from_ptr(comp.ctxt, + comp.void_ptr_type, + p); + + gcc_jit_block_add_assignment (bblock->gcc_bb, + NULL, + lisp_obj_as_ptr, + void_ptr); + return gcc_jit_lvalue_as_rvalue (lisp_obj); +} + static gcc_jit_function * gcc_func_declare (const char *f_name, gcc_jit_type *ret_type, unsigned nargs, gcc_jit_rvalue **args, @@ -564,11 +592,12 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, } basic_block_t *bb_map = compute_bblocks (bytestr_length, bytestr_data); - /* basic_block_t *nil_ret_bb = NULL; */ for (ptrdiff_t i = 0; i < comp_res.max_args; ++i) PUSH_PARAM (gcc_jit_function_get_param (comp.func, i)); + gcc_jit_rvalue *nil = gcc_lisp_obj_as_ptr_from_ptr (&bb_map[0], Qnil); + comp.bblock = NULL; while (pc < bytestr_length) @@ -623,9 +652,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, op = FETCH; varref: { - args[0] = gcc_jit_context_new_rvalue_from_ptr(comp.ctxt, - comp.lisp_obj_type, - vectorp[op]); + args[0] = gcc_lisp_obj_as_ptr_from_ptr (comp.bblock, vectorp[op]); res = gcc_emit_call ("Fsymbol_value", comp.lisp_obj_type, 1, args); PUSH_LVAL (res); break; @@ -650,10 +677,8 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, { POP1; args[1] = args[0]; - args[0] = gcc_jit_context_new_rvalue_from_ptr(comp.ctxt, - comp.lisp_obj_type, - vectorp[op]); - args[2] = comp.nil; + args[0] = gcc_lisp_obj_as_ptr_from_ptr (comp.bblock, vectorp[op]); + args[2] = nil; args[3] = gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.int_type, SET_INTERNAL_SET); @@ -679,9 +704,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, op -= Bvarbind; varbind: { - args[0] = gcc_jit_context_new_rvalue_from_ptr(comp.ctxt, - comp.lisp_obj_type, - vectorp[op]); + args[0] = gcc_lisp_obj_as_ptr_from_ptr (comp.bblock, vectorp[op]); pop (1, &stack, &args[1]); res = gcc_emit_call ("specbind", comp.lisp_obj_type, 2, args); PUSH_LVAL (res); @@ -770,9 +793,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, make_list: { POP1; - args[1] = gcc_jit_context_new_rvalue_from_ptr(comp.ctxt, - comp.lisp_obj_type, - Qnil); + args[1] = nil; res = gcc_emit_call ("Fcons", comp.lisp_obj_type, 2, args); PUSH_LVAL (res); for (int i = 0; i < op; ++i) @@ -876,7 +897,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, case Bindent_to: POP1; - args[1] = comp.nil; + args[1] = nil; res = gcc_emit_call ("Findent_to", comp.lisp_obj_type, 2, args); PUSH_LVAL (res); break; @@ -903,9 +924,8 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, break; case Binteractive_p: /* Obsolete since 24.1. */ - PUSH_RVAL (gcc_jit_context_new_rvalue_from_ptr (comp.ctxt, - comp.lisp_obj_type, - intern ("interactive-p"))); + PUSH_RVAL (gcc_lisp_obj_as_ptr_from_ptr (comp.bblock, + intern ("interactive-p"))); res = gcc_emit_call ("call0", comp.lisp_obj_type, 1, args); PUSH_LVAL (res); break; @@ -937,14 +957,14 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, case Bgotoifnil: op = FETCH2; POP1; - gcc_emit_conditional (GCC_JIT_COMPARISON_EQ, args[0], comp.nil, + gcc_emit_conditional (GCC_JIT_COMPARISON_EQ, args[0], nil, bb_map[op].gcc_bb, bb_map[pc].gcc_bb); break; case Bgotoifnonnil: op = FETCH2; POP1; - gcc_emit_conditional (GCC_JIT_COMPARISON_NE, args[0], comp.nil, + gcc_emit_conditional (GCC_JIT_COMPARISON_NE, args[0], nil, bb_map[op].gcc_bb, bb_map[pc].gcc_bb); break; @@ -952,7 +972,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, op = FETCH2; gcc_emit_conditional (GCC_JIT_COMPARISON_EQ, gcc_jit_lvalue_as_rvalue (TOS), - comp.nil, + nil, bb_map[op].gcc_bb, bb_map[pc].gcc_bb); POP1; break; @@ -961,7 +981,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, op = FETCH2; gcc_emit_conditional (GCC_JIT_COMPARISON_NE, gcc_jit_lvalue_as_rvalue (TOS), - comp.nil, + nil, bb_map[op].gcc_bb, bb_map[pc].gcc_bb); POP1; break; @@ -995,9 +1015,8 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, break; case Bsave_restriction: - args[0] = gcc_jit_context_new_rvalue_from_ptr(comp.ctxt, - comp.void_ptr_type, - save_restriction_restore); + args[0] = gcc_lisp_obj_as_ptr_from_ptr (comp.bblock, + save_restriction_restore); args[1] = gcc_jit_lvalue_as_rvalue (gcc_emit_call ("save_restriction_save", comp.lisp_obj_type, @@ -1009,9 +1028,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, case Bcatch: /* Obsolete since 24.4. */ POP2; args[2] = args[1]; - args[1] = gcc_jit_context_new_rvalue_from_ptr(comp.ctxt, - comp.void_ptr_type, - eval_sub); + args[1] = gcc_lisp_obj_as_ptr_from_ptr (comp.bblock, eval_sub); gcc_emit_call ("internal_catch", comp.void_ptr_type, 3, args); break; @@ -1126,7 +1143,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, op = FETCH - 128; op += pc; POP1; - gcc_emit_conditional (GCC_JIT_COMPARISON_EQ, args[0], comp.nil, + gcc_emit_conditional (GCC_JIT_COMPARISON_EQ, args[0], nil, bb_map[op].gcc_bb, bb_map[pc].gcc_bb); break; @@ -1134,7 +1151,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, op = FETCH - 128; op += pc; POP1; - gcc_emit_conditional (GCC_JIT_COMPARISON_NE, args[0], comp.nil, + gcc_emit_conditional (GCC_JIT_COMPARISON_NE, args[0], nil, bb_map[op].gcc_bb, bb_map[pc].gcc_bb); break; @@ -1143,7 +1160,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, op += pc; gcc_emit_conditional (GCC_JIT_COMPARISON_EQ, gcc_jit_lvalue_as_rvalue (TOS), - comp.nil, + nil, bb_map[op].gcc_bb, bb_map[pc].gcc_bb); POP1; break; @@ -1153,7 +1170,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, op += pc; gcc_emit_conditional (GCC_JIT_COMPARISON_NE, gcc_jit_lvalue_as_rvalue (TOS), - comp.nil, + nil, bb_map[op].gcc_bb, bb_map[pc].gcc_bb); POP1; break; @@ -1192,9 +1209,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, if (pc >= bytestr_length || bytestr_data[pc] != Bswitch) { gcc_jit_rvalue *c = - gcc_jit_context_new_rvalue_from_ptr(comp.ctxt, - comp.lisp_obj_type, - vectorp[op]); + gcc_lisp_obj_as_ptr_from_ptr (comp.bblock, vectorp[op]); PUSH_RVAL (c); /* Fprint(vectorp[op], Qnil); */ break; @@ -1342,19 +1357,44 @@ init_comp (void) { comp.ctxt = gcc_jit_context_acquire(); + comp.void_type = gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_VOID); + comp.void_ptr_type = + gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_VOID_PTR); + comp.int_type = gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_INT); + comp.long_type = gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_LONG); + comp.long_long_type = gcc_jit_context_get_type (comp.ctxt, + GCC_JIT_TYPE_LONG_LONG); + #if EMACS_INT_MAX <= LONG_MAX /* 32-bit builds without wide ints, 64-bit builds on Posix hosts. */ - comp.lisp_obj_type = gcc_jit_context_get_type(comp.ctxt, GCC_JIT_TYPE_VOID_PTR); + comp.lisp_obj_as_ptr = gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.void_ptr_type, + "obj"); + comp.lisp_obj_as_num = gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.long_long_type, + "num"); + #else /* 64-bit builds on MS-Windows, 32-bit builds with wide ints. */ - comp.lisp_obj_type = gcc_jit_context_get_type(comp.ctxt, GCC_JIT_TYPE_LONG_LONG); + comp.lisp_obj_as_ptr = gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.long_long_type, + "obj"); + comp.lisp_obj_as_num = gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.long_long_type, + "num"); #endif - comp.void_type = gcc_jit_context_get_type(comp.ctxt, GCC_JIT_TYPE_VOID); - comp.int_type = gcc_jit_context_get_type(comp.ctxt, GCC_JIT_TYPE_INT); - comp.long_type = gcc_jit_context_get_type(comp.ctxt, GCC_JIT_TYPE_LONG); - comp.void_ptr_type = - gcc_jit_context_get_type(comp.ctxt, GCC_JIT_TYPE_VOID_PTR); + gcc_jit_field *lisp_obj_fields[2] = { comp.lisp_obj_as_ptr, + comp.lisp_obj_as_num }; + comp.lisp_obj_type = gcc_jit_context_new_union_type (comp.ctxt, + NULL, + "LispObj", + 2, + lisp_obj_fields); comp.most_positive_fixnum = gcc_jit_context_new_rvalue_from_long (comp.ctxt, comp.long_type, /* FIXME? */ @@ -1365,8 +1405,9 @@ init_comp (void) MOST_NEGATIVE_FIXNUM); comp.one = gcc_jit_context_new_rvalue_from_int (comp.ctxt, - comp.lisp_obj_type, + comp.int_type, 1); + enum gcc_jit_types ptrdiff_t_gcc; if (sizeof (ptrdiff_t) == sizeof (int)) ptrdiff_t_gcc = GCC_JIT_TYPE_INT; @@ -1379,10 +1420,6 @@ init_comp (void) comp.ptrdiff_type = gcc_jit_context_get_type(comp.ctxt, ptrdiff_t_gcc); - comp.nil = gcc_jit_context_new_rvalue_from_ptr(comp.ctxt, - comp.lisp_obj_type, - Qnil); - comp.scratch = gcc_jit_lvalue_get_address( gcc_jit_context_new_global (comp.ctxt, NULL, commit 16b2a5471eaa7ae2514398720696b3da12514e84 Author: Andrea Corallo Date: Sat Jun 8 11:52:21 2019 +0200 add some new constant diff --git a/src/comp.c b/src/comp.c index 48db20a278..8a88e5819c 100644 --- a/src/comp.c +++ b/src/comp.c @@ -150,12 +150,16 @@ typedef struct { gcc_jit_context *ctxt; gcc_jit_type *void_type; gcc_jit_type *int_type; + gcc_jit_type *long_type; gcc_jit_type *void_ptr_type; gcc_jit_type *ptrdiff_type; gcc_jit_type *lisp_obj_type; gcc_jit_function *func; /* Current function being compiled */ gcc_jit_rvalue *nil; gcc_jit_rvalue *scratch; /* Will point to scratch_call_area */ + gcc_jit_rvalue *most_positive_fixnum; + gcc_jit_rvalue *most_negative_fixnum; + gcc_jit_rvalue *one; basic_block_t *bblock; /* Current basic block */ Lisp_Object func_hash; /* f_name -> gcc_func */ } comp_t; @@ -1348,9 +1352,21 @@ init_comp (void) comp.void_type = gcc_jit_context_get_type(comp.ctxt, GCC_JIT_TYPE_VOID); comp.int_type = gcc_jit_context_get_type(comp.ctxt, GCC_JIT_TYPE_INT); + comp.long_type = gcc_jit_context_get_type(comp.ctxt, GCC_JIT_TYPE_LONG); comp.void_ptr_type = gcc_jit_context_get_type(comp.ctxt, GCC_JIT_TYPE_VOID_PTR); - + comp.most_positive_fixnum = + gcc_jit_context_new_rvalue_from_long (comp.ctxt, + comp.long_type, /* FIXME? */ + MOST_POSITIVE_FIXNUM); + comp.most_negative_fixnum = + gcc_jit_context_new_rvalue_from_long (comp.ctxt, + comp.long_type, /* FIXME? */ + MOST_NEGATIVE_FIXNUM); + comp.one = + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.lisp_obj_type, + 1); enum gcc_jit_types ptrdiff_t_gcc; if (sizeof (ptrdiff_t) == sizeof (int)) ptrdiff_t_gcc = GCC_JIT_TYPE_INT; commit 5cbb6ad8951e8393c3cd728738214a0c87e149be Author: Andrea Corallo Date: Wed Jun 5 12:21:40 2019 +0200 better errors diff --git a/src/comp.c b/src/comp.c index e990c6e576..48db20a278 100644 --- a/src/comp.c +++ b/src/comp.c @@ -733,13 +733,13 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, } break; case Bpophandler: - error ("Bpophandler\n"); + error ("Bpophandler unsupported bytecode\n"); break; case Bpushconditioncase: - error ("Bpushconditioncase\n"); + error ("Bpushconditioncase unsupported bytecode\n"); break; case Bpushcatch: - error ("Bpushcatch\n"); + error ("Bpushcatch unsupported bytecode\n"); break; CASE_CALL_NARGS (nth, 2); @@ -805,31 +805,31 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, break; case Bsub1: - error ("Bsub1\n"); + error ("Bsub1 unsupported bytecode\n"); break; case Badd1: - error ("Badd1\n"); + error ("Badd1 unsupported bytecode\n"); break; case Beqlsign: - error ("Beqlsign\n"); + error ("Beqlsign unsupported bytecode\n"); break; case Bgtr: - error ("Bgtr\n"); + error ("Bgtr unsupported bytecode\n"); break; case Blss: - error ("Blss\n"); + error ("Blss unsupported bytecode\n"); break; case Bleq: - error ("Bleq\n"); + error ("Bleq unsupported bytecode\n"); break; case Bgeq: - error ("Bgeq\n"); + error ("Bgeq unsupported bytecode\n"); break; case Bdiff: EMIT_SCRATCH_CALL_N ("Fminus", 2); break; case Bnegate: - error ("Bnegate\n"); + error ("Bnegate unsupported bytecode\n"); break; case Bplus: EMIT_SCRATCH_CALL_N ("Fplus", 2); @@ -844,7 +844,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, EMIT_SCRATCH_CALL_N ("Ftimes", 2); break; case Bpoint: - error ("Bpoint\n"); + error ("Bpoint unsupported bytecode\n"); break; CASE_CALL_NARGS (goto_char, 1); @@ -854,10 +854,10 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, break; case Bpoint_max: - error ("Bpoint_max\n"); + error ("Bpoint_max unsupported bytecode\n"); break; case Bpoint_min: - error ("Bpoint_min\n"); + error ("Bpoint_min unsupported bytecode\n"); break; CASE_CALL_NARGS (char_after, 1); @@ -880,13 +880,13 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, CASE_CALL_NARGS (eolp, 0); case Beobp: - error ("Beobp\n"); + error ("Beobp unsupported bytecode\n"); break; CASE_CALL_NARGS (bolp, 0); case Bbobp: - error ("Bbobp\n"); + error ("Bbobp unsupported bytecode\n"); break; CASE_CALL_NARGS (current_buffer, 0); commit b3038fa86716edfe9f015c3d0a4c53b9a61c975e Author: Andrea Corallo Date: Tue Jun 4 22:16:19 2019 +0200 add relative branch ops diff --git a/src/comp.c b/src/comp.c index f9e77b1647..e990c6e576 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1108,21 +1108,52 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, case Bintegerp: error ("Bintegerp not supported"); break; + case BRgoto: - error ("BRgoto not supported"); + op = FETCH - 128; + op += pc; + gcc_jit_block_end_with_jump (comp.bblock->gcc_bb, + NULL, + bb_map[op].gcc_bb); + comp.bblock->terminated = true; break; + case BRgotoifnil: - error ("BRgotoifnil not supported"); + op = FETCH - 128; + op += pc; + POP1; + gcc_emit_conditional (GCC_JIT_COMPARISON_EQ, args[0], comp.nil, + bb_map[op].gcc_bb, bb_map[pc].gcc_bb); break; + case BRgotoifnonnil: - error ("BRgotoifnonnil not supported"); + op = FETCH - 128; + op += pc; + POP1; + gcc_emit_conditional (GCC_JIT_COMPARISON_NE, args[0], comp.nil, + bb_map[op].gcc_bb, bb_map[pc].gcc_bb); break; + case BRgotoifnilelsepop: - error ("BRgotoifnilelsepop not supported"); + op = FETCH - 128; + op += pc; + gcc_emit_conditional (GCC_JIT_COMPARISON_EQ, + gcc_jit_lvalue_as_rvalue (TOS), + comp.nil, + bb_map[op].gcc_bb, bb_map[pc].gcc_bb); + POP1; break; + case BRgotoifnonnilelsepop: - error ("BRgotoifnonnilelsepop not supported"); + op = FETCH - 128; + op += pc; + gcc_emit_conditional (GCC_JIT_COMPARISON_NE, + gcc_jit_lvalue_as_rvalue (TOS), + comp.nil, + bb_map[op].gcc_bb, bb_map[pc].gcc_bb); + POP1; break; + case BinsertN: error ("BinsertN not supported"); break; commit 2b56339f75811a670a18439fedd17de932662c78 Author: Andrea Corallo Date: Sun May 26 11:02:56 2019 +0200 adding conditionals diff --git a/src/comp.c b/src/comp.c index ffc79d1c24..f9e77b1647 100644 --- a/src/comp.c +++ b/src/comp.c @@ -30,7 +30,7 @@ along with GNU Emacs. If not, see . */ #include "atimer.h" #include "window.h" -#define COMP_DEBUG 0 +#define COMP_DEBUG 1 #define MAX_FUN_NAME 256 @@ -43,40 +43,67 @@ along with GNU Emacs. If not, see . */ #define CHECK_STACK \ eassert (stack >= stack_base && stack < stack_over) -#define PUSH(obj) \ - do { \ - CHECK_STACK; \ - *stack = obj; \ - stack++; \ +#define PUSH_LVAL(obj) \ + do { \ + CHECK_STACK; \ + gcc_jit_block_add_assignment (comp.bblock->gcc_bb, \ + NULL, \ + *stack, \ + gcc_jit_lvalue_as_rvalue(obj)); \ + stack++; \ + } while (0) + +#define PUSH_RVAL(obj) \ + do { \ + CHECK_STACK; \ + gcc_jit_block_add_assignment (comp.bblock->gcc_bb, \ + NULL, \ + *stack, \ + (obj)); \ + stack++; \ + } while (0) + +/* This always happens in the first basic block. */ + +#define PUSH_PARAM(obj) \ + do { \ + CHECK_STACK; \ + gcc_jit_block_add_assignment (bb_map[0].gcc_bb, \ + NULL, \ + *stack, \ + gcc_jit_param_as_rvalue(obj)); \ + stack++; \ } while (0) +#define TOS (*(stack - 1)) + #define POP0 -#define POP1 \ - do { \ - stack--; \ - CHECK_STACK; \ - args[0] = *stack; \ +#define POP1 \ + do { \ + stack--; \ + CHECK_STACK; \ + args[0] = gcc_jit_lvalue_as_rvalue (*stack); \ } while (0) -#define POP2 \ - do { \ - stack--; \ - CHECK_STACK; \ - args[1] = *stack; \ - stack--; \ - args[0] = *stack; \ +#define POP2 \ + do { \ + stack--; \ + CHECK_STACK; \ + args[1] = gcc_jit_lvalue_as_rvalue (*stack); \ + stack--; \ + args[0] = gcc_jit_lvalue_as_rvalue (*stack); \ } while (0) -#define POP3 \ - do { \ - stack--; \ - CHECK_STACK; \ - args[2] = *stack; \ - stack--; \ - args[1] = *stack; \ - stack--; \ - args[0] = *stack; \ +#define POP3 \ + do { \ + stack--; \ + CHECK_STACK; \ + args[2] = gcc_jit_lvalue_as_rvalue (*stack); \ + stack--; \ + args[1] = gcc_jit_lvalue_as_rvalue (*stack); \ + stack--; \ + args[0] = gcc_jit_lvalue_as_rvalue (*stack); \ } while (0) /* Fetch the next byte from the bytecode stream. */ @@ -88,10 +115,6 @@ along with GNU Emacs. If not, see . */ #define FETCH2 (op = FETCH, op + (FETCH << 8)) -/* Discard n values from the stack. */ - -#define DISCARD(n) (stack -= (n)) - #define STR(s) #s /* With most of the ops we need to do the same stuff so this macros are meant @@ -103,7 +126,7 @@ along with GNU Emacs. If not, see . */ case B##name: \ POP##nargs; \ res = gcc_emit_call (STR(F##name), comp.lisp_obj_type, nargs, args); \ - PUSH (gcc_jit_lvalue_as_rvalue (res)); \ + PUSH_LVAL (res); \ break /* Emit calls to functions with prototype (ptrdiff_t nargs, Lisp_Object *args) @@ -113,9 +136,14 @@ along with GNU Emacs. If not, see . */ do { \ pop (nargs, &stack, args); \ res = gcc_emit_callN (name, nargs, args); \ - PUSH (gcc_jit_lvalue_as_rvalue (res)); \ + PUSH_LVAL (res); \ } while (0) +typedef struct { + gcc_jit_block *gcc_bb; + bool terminated; +} basic_block_t; + /* The compiler context */ typedef struct { @@ -128,7 +156,7 @@ typedef struct { gcc_jit_function *func; /* Current function being compiled */ gcc_jit_rvalue *nil; gcc_jit_rvalue *scratch; /* Will point to scratch_call_area */ - gcc_jit_block *bblock; /* Current basic block */ + basic_block_t *bblock; /* Current basic block */ Lisp_Object func_hash; /* f_name -> gcc_func */ } comp_t; @@ -136,7 +164,7 @@ static comp_t comp; Lisp_Object scratch_call_area[MAX_ARGS]; -FILE *logfile; +FILE *logfile = NULL; /* The result of one function compilation. */ @@ -145,7 +173,7 @@ typedef struct { short min_args, max_args; } comp_f_res_t; -INLINE static void pop (unsigned n, gcc_jit_rvalue ***stack_ref, +INLINE static void pop (unsigned n, gcc_jit_lvalue ***stack_ref, gcc_jit_rvalue *args[]); void emacs_native_compile (const char *lisp_f_name, const char *c_f_name, @@ -162,14 +190,14 @@ bcall0 (Lisp_Object f) order. */ INLINE static void -pop (unsigned n, gcc_jit_rvalue ***stack_ref, gcc_jit_rvalue *args[]) +pop (unsigned n, gcc_jit_lvalue ***stack_ref, gcc_jit_rvalue *args[]) { - gcc_jit_rvalue **stack = *stack_ref; + gcc_jit_lvalue **stack = *stack_ref; while (n--) { stack--; - args[n] = *stack; + args[n] = gcc_jit_lvalue_as_rvalue (*stack); } *stack_ref = stack; @@ -278,7 +306,7 @@ gcc_emit_call (const char *f_name, gcc_jit_type *ret_type, unsigned nargs, NULL, ret_type, "res"); - gcc_jit_block_add_assignment(comp.bblock, NULL, + gcc_jit_block_add_assignment(comp.bblock->gcc_bb, NULL, res, gcc_jit_context_new_call(comp.ctxt, NULL, @@ -312,7 +340,7 @@ gcc_emit_callN (const char *f_name, unsigned nargs, gcc_jit_rvalue **args) gcc_jit_type_get_pointer (comp.lisp_obj_type), "p"); - gcc_jit_block_add_assignment(comp.bblock, NULL, + gcc_jit_block_add_assignment(comp.bblock->gcc_bb, NULL, p, comp.scratch); @@ -322,7 +350,7 @@ gcc_emit_callN (const char *f_name, unsigned nargs, gcc_jit_rvalue **args) gcc_jit_context_get_type(comp.ctxt, GCC_JIT_TYPE_UNSIGNED_INT), i); - gcc_jit_block_add_assignment (comp.bblock, NULL, + gcc_jit_block_add_assignment (comp.bblock->gcc_bb, NULL, gcc_jit_context_new_array_access (comp.ctxt, NULL, gcc_jit_lvalue_as_rvalue(p), @@ -347,13 +375,13 @@ ucmp(const void *a, const void *b) } /* Compute and initialize all basic blocks. */ -static gcc_jit_block ** +static basic_block_t * compute_bblocks (ptrdiff_t bytestr_length, unsigned char *bytestr_data) { ptrdiff_t pc = 0; unsigned op; bool new_bb = true; - gcc_jit_block **bb_map = xmalloc (bytestr_length * sizeof (gcc_jit_block *)); + basic_block_t *bb_map = xmalloc (bytestr_length * sizeof (basic_block_t)); unsigned *bb_start_pc = xmalloc (bytestr_length * sizeof (unsigned)); unsigned bb_n = 0; @@ -438,13 +466,14 @@ compute_bblocks (ptrdiff_t bytestr_length, unsigned char *bytestr_data) /* printf ("%d ", bb_start_pc[i]); */ /* printf ("\n"); */ - gcc_jit_block *curr_bb; + basic_block_t curr_bb; for (int i = 0, pc = 0; pc < bytestr_length; pc++) { if (i < bb_n && pc == bb_start_pc[i]) { ++i; - curr_bb = gcc_jit_function_new_block (comp.func, NULL); + curr_bb.gcc_bb = gcc_jit_function_new_block (comp.func, NULL); + curr_bb.terminated = false; } bb_map[pc] = curr_bb; } @@ -454,6 +483,27 @@ compute_bblocks (ptrdiff_t bytestr_length, unsigned char *bytestr_data) return bb_map; } +/* Close current basic block emitting a conditional. */ + +static gcc_jit_rvalue * +gcc_emit_conditional (enum gcc_jit_comparison op, + gcc_jit_rvalue *a, gcc_jit_rvalue *b, + gcc_jit_block *then_target, gcc_jit_block *else_target) +{ + gcc_jit_rvalue *test = gcc_jit_context_new_comparison (comp.ctxt, + NULL, + op, + a, b); + gcc_jit_block_end_with_conditional (comp.bblock->gcc_bb, + NULL, + test, + then_target, + else_target); + comp.bblock->terminated = true; + + return test; +} + static comp_f_res_t compile_f (const char *f_name, ptrdiff_t bytestr_length, unsigned char *bytestr_data, @@ -468,9 +518,9 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, /* This is the stack we use to flat the bytecode written for push and pop Emacs VM.*/ - gcc_jit_rvalue **stack_base, **stack, **stack_over; + gcc_jit_lvalue **stack_base, **stack, **stack_over; stack_base = stack = - (gcc_jit_rvalue **) xmalloc (stack_depth * sizeof (gcc_jit_rvalue *)); + (gcc_jit_lvalue **) xmalloc (stack_depth * sizeof (gcc_jit_lvalue *)); stack_over = stack_base + stack_depth; if (FIXNUMP (args_template)) @@ -499,15 +549,35 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, comp.func = gcc_func_declare (f_name, comp.lisp_obj_type, comp_res.max_args, NULL, GCC_JIT_FUNCTION_EXPORTED, false); - gcc_jit_block **bb_map = compute_bblocks (bytestr_length, bytestr_data); + char local_name[256]; + for (int i = 0; i < stack_depth; ++i) + { + snprintf (local_name, sizeof (local_name), "local_%d", i); + stack[i] = gcc_jit_function_new_local (comp.func, + NULL, + comp.lisp_obj_type, + local_name); + } + basic_block_t *bb_map = compute_bblocks (bytestr_length, bytestr_data); + /* basic_block_t *nil_ret_bb = NULL; */ for (ptrdiff_t i = 0; i < comp_res.max_args; ++i) - PUSH (gcc_jit_param_as_rvalue (gcc_jit_function_get_param (comp.func, i))); + PUSH_PARAM (gcc_jit_function_get_param (comp.func, i)); + + comp.bblock = NULL; while (pc < bytestr_length) { - comp.bblock = bb_map[pc]; + /* If we are changing BB and the last was one wasn't terminated + terminate it with a fall through. */ + if (comp.bblock && comp.bblock->gcc_bb != bb_map[pc].gcc_bb && + !comp.bblock->terminated) + { + gcc_jit_block_end_with_jump (comp.bblock->gcc_bb, NULL, bb_map[pc].gcc_bb); + comp.bblock->terminated = true; + } + comp.bblock = &bb_map[pc]; op = FETCH; switch (op) @@ -518,17 +588,17 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, case Bstack_ref4: case Bstack_ref5: { - PUSH (stack_base[(stack - stack_base) - (op - Bstack_ref) - 1]); + PUSH_LVAL (stack_base[(stack - stack_base) - (op - Bstack_ref) - 1]); break; } case Bstack_ref6: { - PUSH (stack_base[(stack - stack_base) - FETCH - 1]); + PUSH_LVAL (stack_base[(stack - stack_base) - FETCH - 1]); break; } case Bstack_ref7: { - PUSH (stack_base[(stack - stack_base) - FETCH2 - 1]); + PUSH_LVAL (stack_base[(stack - stack_base) - FETCH2 - 1]); break; } @@ -553,7 +623,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, comp.lisp_obj_type, vectorp[op]); res = gcc_emit_call ("Fsymbol_value", comp.lisp_obj_type, 1, args); - PUSH (gcc_jit_lvalue_as_rvalue (res)); + PUSH_LVAL (res); break; } @@ -584,7 +654,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, comp.int_type, SET_INTERNAL_SET); res = gcc_emit_call ("set_internal", comp.lisp_obj_type, 4, args); - PUSH (gcc_jit_lvalue_as_rvalue (res)); + PUSH_LVAL (res); } break; @@ -610,7 +680,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, vectorp[op]); pop (1, &stack, &args[1]); res = gcc_emit_call ("specbind", comp.lisp_obj_type, 2, args); - PUSH (gcc_jit_lvalue_as_rvalue (res)); + PUSH_LVAL (res); break; } @@ -634,7 +704,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, ptrdiff_t nargs = op + 1; pop (nargs, &stack, args); res = gcc_emit_callN ("Ffuncall", nargs, args); - PUSH (gcc_jit_lvalue_as_rvalue (res)); + PUSH_LVAL (res); break; } @@ -700,12 +770,12 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, comp.lisp_obj_type, Qnil); res = gcc_emit_call ("Fcons", comp.lisp_obj_type, 2, args); - PUSH (gcc_jit_lvalue_as_rvalue (res)); + PUSH_LVAL (res); for (int i = 0; i < op; ++i) { POP2; res = gcc_emit_call ("Fcons", comp.lisp_obj_type, 2, args); - PUSH (gcc_jit_lvalue_as_rvalue (res)); + PUSH_LVAL (res); } break; } @@ -795,7 +865,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, case Bpreceding_char: res = gcc_emit_call ("Fprevious_char", comp.lisp_obj_type, 0, args); - PUSH (gcc_jit_lvalue_as_rvalue (res)); + PUSH_LVAL (res); break; CASE_CALL_NARGS (current_column, 0); @@ -804,7 +874,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, POP1; args[1] = comp.nil; res = gcc_emit_call ("Findent_to", comp.lisp_obj_type, 2, args); - PUSH (gcc_jit_lvalue_as_rvalue (res)); + PUSH_LVAL (res); break; CASE_CALL_NARGS (eolp, 0); @@ -829,11 +899,11 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, break; case Binteractive_p: /* Obsolete since 24.1. */ - PUSH (gcc_jit_context_new_rvalue_from_ptr(comp.ctxt, - comp.lisp_obj_type, - intern ("interactive-p"))); + PUSH_RVAL (gcc_jit_context_new_rvalue_from_ptr (comp.ctxt, + comp.lisp_obj_type, + intern ("interactive-p"))); res = gcc_emit_call ("call0", comp.lisp_obj_type, 1, args); - PUSH (gcc_jit_lvalue_as_rvalue (res)); + PUSH_LVAL (res); break; CASE_CALL_NARGS (forward_char, 1); @@ -853,37 +923,59 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, break; case Bgoto: - error ("Bgoto not supported"); + op = FETCH2; + gcc_jit_block_end_with_jump (comp.bblock->gcc_bb, + NULL, + bb_map[op].gcc_bb); + comp.bblock->terminated = true; break; + case Bgotoifnil: - POP1; op = FETCH2; - /* PUSH_PC (op); */ - /* error ("Bgotoifnil not supported"); */ + POP1; + gcc_emit_conditional (GCC_JIT_COMPARISON_EQ, args[0], comp.nil, + bb_map[op].gcc_bb, bb_map[pc].gcc_bb); break; + case Bgotoifnonnil: - error ("Bgotoifnonnil not supported"); + op = FETCH2; + POP1; + gcc_emit_conditional (GCC_JIT_COMPARISON_NE, args[0], comp.nil, + bb_map[op].gcc_bb, bb_map[pc].gcc_bb); break; + case Bgotoifnilelsepop: - error ("Bgotoifnilelsepop not supported"); + op = FETCH2; + gcc_emit_conditional (GCC_JIT_COMPARISON_EQ, + gcc_jit_lvalue_as_rvalue (TOS), + comp.nil, + bb_map[op].gcc_bb, bb_map[pc].gcc_bb); + POP1; break; + case Bgotoifnonnilelsepop: - error ("Bgotoifnonnilelsepop not supported"); + op = FETCH2; + gcc_emit_conditional (GCC_JIT_COMPARISON_NE, + gcc_jit_lvalue_as_rvalue (TOS), + comp.nil, + bb_map[op].gcc_bb, bb_map[pc].gcc_bb); + POP1; break; case Breturn: POP1; - gcc_jit_block_end_with_return(comp.bblock, + gcc_jit_block_end_with_return(comp.bblock->gcc_bb, NULL, args[0]); + comp.bblock->terminated = true; break; case Bdiscard: - DISCARD (1); + POP1; break; case Bdup: - PUSH (*(stack - 1)); + PUSH_LVAL (TOS); break; case Bsave_excursion: @@ -895,7 +987,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, POP1; res = gcc_emit_call ("helper_save_window_excursion", comp.lisp_obj_type, 1, args); - PUSH (gcc_jit_lvalue_as_rvalue (res)); + PUSH_LVAL (res); break; case Bsave_restriction: @@ -934,14 +1026,14 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, POP1; res = gcc_emit_call ("helper_temp_output_buffer_setup", comp.lisp_obj_type, 1, args); - PUSH (gcc_jit_lvalue_as_rvalue (res)); + PUSH_LVAL (res); break; case Btemp_output_buffer_show: /* Obsolete since 24.1. */ POP2; gcc_emit_call ("temp_output_buffer_show", comp.void_type, 1, &args[1]); - PUSH (args[0]); + PUSH_RVAL (args[0]); gcc_emit_call ("helper_unbind_n", comp.lisp_obj_type, 1, args); break; @@ -1068,7 +1160,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, gcc_jit_context_new_rvalue_from_ptr(comp.ctxt, comp.lisp_obj_type, vectorp[op]); - PUSH (c); + PUSH_RVAL (c); /* Fprint(vectorp[op], Qnil); */ break; } @@ -1088,6 +1180,8 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, error ("Something went wrong"); exit: + /* if (nil_ret_bb) */ + /* xfree (nil_ret_bb); */ xfree (stack_base); xfree (bb_map); return comp_res; @@ -1273,7 +1367,7 @@ release_comp (void) if (comp.ctxt) gcc_jit_context_release(comp.ctxt); - if (COMP_DEBUG) + if (logfile) fclose (logfile); } diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 006336393d..e1d6f313fd 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -127,6 +127,25 @@ (should (equal (comp-tests-ffuncall-caller-f) '(1 2 3)))) +(ert-deftest comp-tests-conditionals () + "Testing conditionals." + (defun comp-tests-conditionals-1-f (x) + ;; Generate goto-if-nil + (if x 1 2)) + (defun comp-tests-conditionals-2-f (x) + ;; Generate goto-if-nil-else-pop + (when x + 1340)) + (byte-compile #'comp-tests-conditionals-1-f) + (byte-compile #'comp-tests-conditionals-2-f) + (native-compile #'comp-tests-conditionals-1-f) + (native-compile #'comp-tests-conditionals-2-f) + + (should (= (comp-tests-conditionals-1-f t) 1)) + (should (= (comp-tests-conditionals-1-f nil) 2)) + (should (= (comp-tests-conditionals-2-f t) 1340)) + (should (eq (comp-tests-conditionals-2-f nil) nil))) + (ert-deftest comp-tests-gc () "Try to do some longer computation to let the gc kick in." (dotimes (_ 100000) commit c43a9d940a9d033f7770f241f920a537167b211b Author: Andrea Corallo Date: Sat May 25 15:33:02 2019 +0200 add bb computation diff --git a/src/comp.c b/src/comp.c index 3b058348a4..ffc79d1c24 100644 --- a/src/comp.c +++ b/src/comp.c @@ -116,10 +116,6 @@ along with GNU Emacs. If not, see . */ PUSH (gcc_jit_lvalue_as_rvalue (res)); \ } while (0) -/* Current basic block we are emiting in. */ - -#define BBLOCK comp.bblocks[comp.bb_n] - /* The compiler context */ typedef struct { @@ -132,8 +128,7 @@ typedef struct { gcc_jit_function *func; /* Current function being compiled */ gcc_jit_rvalue *nil; gcc_jit_rvalue *scratch; /* Will point to scratch_call_area */ - gcc_jit_block **bblocks; /* Basic blocks */ - unsigned bb_n; /* Current basic block number */ + gcc_jit_block *bblock; /* Current basic block */ Lisp_Object func_hash; /* f_name -> gcc_func */ } comp_t; @@ -283,7 +278,7 @@ gcc_emit_call (const char *f_name, gcc_jit_type *ret_type, unsigned nargs, NULL, ret_type, "res"); - gcc_jit_block_add_assignment(BBLOCK, NULL, + gcc_jit_block_add_assignment(comp.bblock, NULL, res, gcc_jit_context_new_call(comp.ctxt, NULL, @@ -317,7 +312,7 @@ gcc_emit_callN (const char *f_name, unsigned nargs, gcc_jit_rvalue **args) gcc_jit_type_get_pointer (comp.lisp_obj_type), "p"); - gcc_jit_block_add_assignment(BBLOCK, NULL, + gcc_jit_block_add_assignment(comp.bblock, NULL, p, comp.scratch); @@ -327,7 +322,7 @@ gcc_emit_callN (const char *f_name, unsigned nargs, gcc_jit_rvalue **args) gcc_jit_context_get_type(comp.ctxt, GCC_JIT_TYPE_UNSIGNED_INT), i); - gcc_jit_block_add_assignment (BBLOCK, NULL, + gcc_jit_block_add_assignment (comp.bblock, NULL, gcc_jit_context_new_array_access (comp.ctxt, NULL, gcc_jit_lvalue_as_rvalue(p), @@ -343,6 +338,122 @@ gcc_emit_callN (const char *f_name, unsigned nargs, gcc_jit_rvalue **args) return gcc_emit_call (f_name, comp.lisp_obj_type, 2, args); } +static int +ucmp(const void *a, const void *b) +{ +#define _I(x) *(const int*)x + return _I(a) < _I(b) ? -1 : _I(a) > _I(b); +#undef _I +} + +/* Compute and initialize all basic blocks. */ +static gcc_jit_block ** +compute_bblocks (ptrdiff_t bytestr_length, unsigned char *bytestr_data) +{ + ptrdiff_t pc = 0; + unsigned op; + bool new_bb = true; + gcc_jit_block **bb_map = xmalloc (bytestr_length * sizeof (gcc_jit_block *)); + unsigned *bb_start_pc = xmalloc (bytestr_length * sizeof (unsigned)); + unsigned bb_n = 0; + + while (pc < bytestr_length) + { + if (new_bb) + { + bb_start_pc[bb_n++] = pc; + new_bb = false; + } + + op = FETCH; + switch (op) + { + /* 3 byte non branch ops */ + case Bvarref7: + case Bvarset7: + case Bvarbind7: + case Bcall7: + case Bunbind7: + case Bpushcatch: + case Bpushconditioncase: + case Bstack_ref7: + case Bstack_set2: + pc += 2; + break; + /* 2 byte non branch ops */ + case Bvarref6: + case Bvarset6: + case Bvarbind6: + case Bcall6: + case Bunbind6: + case Bconstant2: + case BlistN: + case BconcatN: + case BinsertN: + case Bstack_ref6: + case Bstack_set: + case BdiscardN: + ++pc; + break; + /* Absolute branches */ + case Bgoto: + case Bgotoifnil: + case Bgotoifnonnil: + case Bgotoifnilelsepop: + case Bgotoifnonnilelsepop: + op = FETCH2; + bb_start_pc[bb_n++] = op; + new_bb = true; + break; + /* PC relative branches */ + case BRgoto: + case BRgotoifnil: + case BRgotoifnonnil: + case BRgotoifnilelsepop: + case BRgotoifnonnilelsepop: + op = FETCH - 128; + bb_start_pc[bb_n++] = op; + new_bb = true; + break; + /* Return */ + case Breturn: + new_bb = true; + break; + default: + break; + } + } + + /* Sort and remove possible duplicates. */ + qsort (bb_start_pc, bb_n, sizeof(unsigned), ucmp); + { + unsigned i, j; + for (i = j = 0; i < bb_n; i++) + if (bb_start_pc[i] != bb_start_pc[j]) + bb_start_pc[++j] = bb_start_pc[i]; + bb_n = j + 1; + } + + /* for (int i = 0; i < bb_n; i++) */ + /* printf ("%d ", bb_start_pc[i]); */ + /* printf ("\n"); */ + + gcc_jit_block *curr_bb; + for (int i = 0, pc = 0; pc < bytestr_length; pc++) + { + if (i < bb_n && pc == bb_start_pc[i]) + { + ++i; + curr_bb = gcc_jit_function_new_block (comp.func, NULL); + } + bb_map[pc] = curr_bb; + } + + xfree (bb_start_pc); + + return bb_map; +} + static comp_f_res_t compile_f (const char *f_name, ptrdiff_t bytestr_length, unsigned char *bytestr_data, @@ -362,10 +473,6 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, (gcc_jit_rvalue **) xmalloc (stack_depth * sizeof (gcc_jit_rvalue *)); stack_over = stack_base + stack_depth; - comp.bblocks = - (gcc_jit_block **) xzalloc (bytestr_length * sizeof (gcc_jit_block *)); - comp.bb_n = 0; - if (FIXNUMP (args_template)) { ptrdiff_t at = XFIXNUM (args_template); @@ -388,17 +495,19 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, eassert (SYMBOLP (args_template) && args_template == Qnil); - /* Current function being compiled. Return a lips obj. */ + /* Current function being compiled. */ comp.func = gcc_func_declare (f_name, comp.lisp_obj_type, comp_res.max_args, NULL, GCC_JIT_FUNCTION_EXPORTED, false); + gcc_jit_block **bb_map = compute_bblocks (bytestr_length, bytestr_data); + + for (ptrdiff_t i = 0; i < comp_res.max_args; ++i) PUSH (gcc_jit_param_as_rvalue (gcc_jit_function_get_param (comp.func, i))); - BBLOCK = gcc_jit_function_new_block(comp.func, NULL); - while (pc < bytestr_length) { + comp.bblock = bb_map[pc]; op = FETCH; switch (op) @@ -747,7 +856,10 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, error ("Bgoto not supported"); break; case Bgotoifnil: - error ("Bgotoifnil not supported"); + POP1; + op = FETCH2; + /* PUSH_PC (op); */ + /* error ("Bgotoifnil not supported"); */ break; case Bgotoifnonnil: error ("Bgotoifnonnil not supported"); @@ -761,7 +873,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, case Breturn: POP1; - gcc_jit_block_end_with_return(BBLOCK, + gcc_jit_block_end_with_return(comp.bblock, NULL, args[0]); break; @@ -977,6 +1089,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, exit: xfree (stack_base); + xfree (bb_map); return comp_res; } commit 37381fb9b2cc225d127d8eb7cfc0e42c27cc1413 Author: Andrea Corallo Date: Sat May 25 12:35:27 2019 +0200 generalize bblocks diff --git a/src/comp.c b/src/comp.c index 8cf3131dae..3b058348a4 100644 --- a/src/comp.c +++ b/src/comp.c @@ -109,10 +109,16 @@ along with GNU Emacs. If not, see . */ /* Emit calls to functions with prototype (ptrdiff_t nargs, Lisp_Object *args) This is done aggregating args into the scratch_call_area. */ -#define EMIT_SCRATCH_CALL_N(name, nargs) \ - pop (nargs, &stack, args); \ - res = gcc_emit_callN (name, nargs, args); \ - PUSH (gcc_jit_lvalue_as_rvalue (res)) +#define EMIT_SCRATCH_CALL_N(name, nargs) \ + do { \ + pop (nargs, &stack, args); \ + res = gcc_emit_callN (name, nargs, args); \ + PUSH (gcc_jit_lvalue_as_rvalue (res)); \ + } while (0) + +/* Current basic block we are emiting in. */ + +#define BBLOCK comp.bblocks[comp.bb_n] /* The compiler context */ @@ -126,7 +132,8 @@ typedef struct { gcc_jit_function *func; /* Current function being compiled */ gcc_jit_rvalue *nil; gcc_jit_rvalue *scratch; /* Will point to scratch_call_area */ - gcc_jit_block *block; /* Current basic block */ + gcc_jit_block **bblocks; /* Basic blocks */ + unsigned bb_n; /* Current basic block number */ Lisp_Object func_hash; /* f_name -> gcc_func */ } comp_t; @@ -276,7 +283,7 @@ gcc_emit_call (const char *f_name, gcc_jit_type *ret_type, unsigned nargs, NULL, ret_type, "res"); - gcc_jit_block_add_assignment(comp.block, NULL, + gcc_jit_block_add_assignment(BBLOCK, NULL, res, gcc_jit_context_new_call(comp.ctxt, NULL, @@ -310,7 +317,7 @@ gcc_emit_callN (const char *f_name, unsigned nargs, gcc_jit_rvalue **args) gcc_jit_type_get_pointer (comp.lisp_obj_type), "p"); - gcc_jit_block_add_assignment(comp.block, NULL, + gcc_jit_block_add_assignment(BBLOCK, NULL, p, comp.scratch); @@ -320,7 +327,7 @@ gcc_emit_callN (const char *f_name, unsigned nargs, gcc_jit_rvalue **args) gcc_jit_context_get_type(comp.ctxt, GCC_JIT_TYPE_UNSIGNED_INT), i); - gcc_jit_block_add_assignment (comp.block, NULL, + gcc_jit_block_add_assignment (BBLOCK, NULL, gcc_jit_context_new_array_access (comp.ctxt, NULL, gcc_jit_lvalue_as_rvalue(p), @@ -355,6 +362,10 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, (gcc_jit_rvalue **) xmalloc (stack_depth * sizeof (gcc_jit_rvalue *)); stack_over = stack_base + stack_depth; + comp.bblocks = + (gcc_jit_block **) xzalloc (bytestr_length * sizeof (gcc_jit_block *)); + comp.bb_n = 0; + if (FIXNUMP (args_template)) { ptrdiff_t at = XFIXNUM (args_template); @@ -384,7 +395,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, for (ptrdiff_t i = 0; i < comp_res.max_args; ++i) PUSH (gcc_jit_param_as_rvalue (gcc_jit_function_get_param (comp.func, i))); - comp.block = gcc_jit_function_new_block(comp.func, "foo_blk"); + BBLOCK = gcc_jit_function_new_block(comp.func, NULL); while (pc < bytestr_length) { @@ -750,7 +761,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, case Breturn: POP1; - gcc_jit_block_end_with_return(comp.block, + gcc_jit_block_end_with_return(BBLOCK, NULL, args[0]); break; commit d234e9bc8ae3c8ea1ecb82970a4fd1fd89850249 Author: Andrea Corallo Date: Sat May 25 11:17:01 2019 +0200 add stuffs diff --git a/src/comp.c b/src/comp.c index 08cdf29f9f..8cf3131dae 100644 --- a/src/comp.c +++ b/src/comp.c @@ -539,7 +539,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, comp.ptrdiff_type, op); - res = gcc_emit_call ("unbind_n", comp.lisp_obj_type, 1, args); + gcc_emit_call ("helper_unbind_n", comp.lisp_obj_type, 1, args); } break; case Bpophandler: @@ -801,16 +801,30 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, gcc_emit_call ("helper_unwind_protect", comp.void_type, 1, args); break; - case Bcondition_case: - error ("Bcondition_case not supported"); + case Bcondition_case: /* Obsolete since 24.4. */ + POP3; + gcc_emit_call ("internal_lisp_condition_case", + comp.lisp_obj_type, 3, args); break; - case Btemp_output_buffer_setup: - error ("Btemp_output_buffer_setup not supported"); + + case Btemp_output_buffer_setup: /* Obsolete since 24.1. */ + POP1; + res = gcc_emit_call ("helper_temp_output_buffer_setup", comp.lisp_obj_type, + 1, args); + PUSH (gcc_jit_lvalue_as_rvalue (res)); break; - case Btemp_output_buffer_show: - error ("Btemp_output_buffer_show not supported"); + + case Btemp_output_buffer_show: /* Obsolete since 24.1. */ + POP2; + gcc_emit_call ("temp_output_buffer_show", comp.void_type, 1, + &args[1]); + PUSH (args[0]); + gcc_emit_call ("helper_unbind_n", comp.lisp_obj_type, 1, args); + break; - case Bunbind_all: + case Bunbind_all: /* Obsolete. Never used. */ + /* To unbind back to the beginning of this frame. Not used yet, + but will be needed for tail-recursion elimination. */ error ("Bunbind_all not supported"); break; case Bset_marker: @@ -1156,6 +1170,10 @@ Lisp_Object helper_save_window_excursion (Lisp_Object v1); void helper_unwind_protect (Lisp_Object handler); +Lisp_Object helper_temp_output_buffer_setup (Lisp_Object x); + +Lisp_Object helper_unbind_n (int val); + Lisp_Object helper_save_window_excursion (Lisp_Object v1) { @@ -1174,4 +1192,18 @@ void helper_unwind_protect (Lisp_Object handler) handler); } +Lisp_Object +helper_temp_output_buffer_setup (Lisp_Object x) +{ + CHECK_STRING (x); + temp_output_buffer_setup (SSDATA (x)); + return Vstandard_output; +} + +Lisp_Object +helper_unbind_n (int val) +{ + return unbind_to (SPECPDL_INDEX () - val, Qnil); +} + #endif /* HAVE_LIBJIT */ commit 70fc2a742d28697b0bb05c16665f038f6f79c86e Author: Andrea Corallo Date: Sat May 25 10:52:55 2019 +0200 naming change diff --git a/src/comp.c b/src/comp.c index 3f7e093b57..08cdf29f9f 100644 --- a/src/comp.c +++ b/src/comp.c @@ -102,7 +102,7 @@ along with GNU Emacs. If not, see . */ #define CASE_CALL_NARGS(name, nargs) \ case B##name: \ POP##nargs; \ - res = jit_emit_call (STR(F##name), comp.lisp_obj_type, nargs, args); \ + res = gcc_emit_call (STR(F##name), comp.lisp_obj_type, nargs, args); \ PUSH (gcc_jit_lvalue_as_rvalue (res)); \ break @@ -111,7 +111,7 @@ along with GNU Emacs. If not, see . */ #define EMIT_SCRATCH_CALL_N(name, nargs) \ pop (nargs, &stack, args); \ - res = jit_emit_callN (name, nargs, args); \ + res = gcc_emit_callN (name, nargs, args); \ PUSH (gcc_jit_lvalue_as_rvalue (res)) /* The compiler context */ @@ -174,7 +174,7 @@ pop (unsigned n, gcc_jit_rvalue ***stack_ref, gcc_jit_rvalue *args[]) } static gcc_jit_function * -jit_func_declare (const char *f_name, gcc_jit_type *ret_type, +gcc_func_declare (const char *f_name, gcc_jit_type *ret_type, unsigned nargs, gcc_jit_rvalue **args, enum gcc_jit_function_kind kind, bool reusable) { @@ -253,7 +253,7 @@ jit_func_declare (const char *f_name, gcc_jit_type *ret_type, } static gcc_jit_lvalue * -jit_emit_call (const char *f_name, gcc_jit_type *ret_type, unsigned nargs, +gcc_emit_call (const char *f_name, gcc_jit_type *ret_type, unsigned nargs, gcc_jit_rvalue **args) { Lisp_Object key = make_string (f_name, strlen (f_name)); @@ -263,7 +263,7 @@ jit_emit_call (const char *f_name, gcc_jit_type *ret_type, unsigned nargs, if (i == -1) { - jit_func_declare(f_name, ret_type, nargs, args, GCC_JIT_FUNCTION_IMPORTED, + gcc_func_declare(f_name, ret_type, nargs, args, GCC_JIT_FUNCTION_IMPORTED, true); i = hash_lookup (ht, key, &hash); eassert (i != -1); @@ -287,7 +287,7 @@ jit_emit_call (const char *f_name, gcc_jit_type *ret_type, unsigned nargs, } static gcc_jit_lvalue * -jit_emit_callN (const char *f_name, unsigned nargs, gcc_jit_rvalue **args) +gcc_emit_callN (const char *f_name, unsigned nargs, gcc_jit_rvalue **args) { /* Here we set all the pointers into the scratch call area. */ /* TODO: distinguish primitives for faster calling convention. */ @@ -333,7 +333,7 @@ jit_emit_callN (const char *f_name, unsigned nargs, gcc_jit_rvalue **args) nargs); args[1] = comp.scratch; - return jit_emit_call (f_name, comp.lisp_obj_type, 2, args); + return gcc_emit_call (f_name, comp.lisp_obj_type, 2, args); } static comp_f_res_t @@ -378,7 +378,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, /* Current function being compiled. Return a lips obj. */ - comp.func = jit_func_declare (f_name, comp.lisp_obj_type, comp_res.max_args, + comp.func = gcc_func_declare (f_name, comp.lisp_obj_type, comp_res.max_args, NULL, GCC_JIT_FUNCTION_EXPORTED, false); for (ptrdiff_t i = 0; i < comp_res.max_args; ++i) @@ -432,7 +432,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, args[0] = gcc_jit_context_new_rvalue_from_ptr(comp.ctxt, comp.lisp_obj_type, vectorp[op]); - res = jit_emit_call ("Fsymbol_value", comp.lisp_obj_type, 1, args); + res = gcc_emit_call ("Fsymbol_value", comp.lisp_obj_type, 1, args); PUSH (gcc_jit_lvalue_as_rvalue (res)); break; } @@ -463,7 +463,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, args[3] = gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.int_type, SET_INTERNAL_SET); - res = jit_emit_call ("set_internal", comp.lisp_obj_type, 4, args); + res = gcc_emit_call ("set_internal", comp.lisp_obj_type, 4, args); PUSH (gcc_jit_lvalue_as_rvalue (res)); } break; @@ -489,7 +489,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, comp.lisp_obj_type, vectorp[op]); pop (1, &stack, &args[1]); - res = jit_emit_call ("specbind", comp.lisp_obj_type, 2, args); + res = gcc_emit_call ("specbind", comp.lisp_obj_type, 2, args); PUSH (gcc_jit_lvalue_as_rvalue (res)); break; } @@ -513,7 +513,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, { ptrdiff_t nargs = op + 1; pop (nargs, &stack, args); - res = jit_emit_callN ("Ffuncall", nargs, args); + res = gcc_emit_callN ("Ffuncall", nargs, args); PUSH (gcc_jit_lvalue_as_rvalue (res)); break; } @@ -539,7 +539,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, comp.ptrdiff_type, op); - res = jit_emit_call ("unbind_n", comp.lisp_obj_type, 1, args); + res = gcc_emit_call ("unbind_n", comp.lisp_obj_type, 1, args); } break; case Bpophandler: @@ -579,12 +579,12 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, args[1] = gcc_jit_context_new_rvalue_from_ptr(comp.ctxt, comp.lisp_obj_type, Qnil); - res = jit_emit_call ("Fcons", comp.lisp_obj_type, 2, args); + res = gcc_emit_call ("Fcons", comp.lisp_obj_type, 2, args); PUSH (gcc_jit_lvalue_as_rvalue (res)); for (int i = 0; i < op; ++i) { POP2; - res = jit_emit_call ("Fcons", comp.lisp_obj_type, 2, args); + res = gcc_emit_call ("Fcons", comp.lisp_obj_type, 2, args); PUSH (gcc_jit_lvalue_as_rvalue (res)); } break; @@ -674,7 +674,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, CASE_CALL_NARGS (following_char, 0); case Bpreceding_char: - res = jit_emit_call ("Fprevious_char", comp.lisp_obj_type, 0, args); + res = gcc_emit_call ("Fprevious_char", comp.lisp_obj_type, 0, args); PUSH (gcc_jit_lvalue_as_rvalue (res)); break; @@ -683,7 +683,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, case Bindent_to: POP1; args[1] = comp.nil; - res = jit_emit_call ("Findent_to", comp.lisp_obj_type, 2, args); + res = gcc_emit_call ("Findent_to", comp.lisp_obj_type, 2, args); PUSH (gcc_jit_lvalue_as_rvalue (res)); break; @@ -704,7 +704,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, case Bsave_current_buffer: /* Obsolete since ??. */ case Bsave_current_buffer_1: - jit_emit_call ("record_unwind_current_buffer", + gcc_emit_call ("record_unwind_current_buffer", comp.void_type, 0, NULL); break; @@ -712,7 +712,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, PUSH (gcc_jit_context_new_rvalue_from_ptr(comp.ctxt, comp.lisp_obj_type, intern ("interactive-p"))); - res = jit_emit_call ("call0", comp.lisp_obj_type, 1, args); + res = gcc_emit_call ("call0", comp.lisp_obj_type, 1, args); PUSH (gcc_jit_lvalue_as_rvalue (res)); break; @@ -764,13 +764,13 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, break; case Bsave_excursion: - res = jit_emit_call ("record_unwind_protect_excursion", + res = gcc_emit_call ("record_unwind_protect_excursion", comp.void_type, 0, args); break; case Bsave_window_excursion: /* Obsolete since 24.1. */ POP1; - res = jit_emit_call ("helper_save_window_excursion", + res = gcc_emit_call ("helper_save_window_excursion", comp.lisp_obj_type, 1, args); PUSH (gcc_jit_lvalue_as_rvalue (res)); break; @@ -780,11 +780,11 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, comp.void_ptr_type, save_restriction_restore); args[1] = - gcc_jit_lvalue_as_rvalue (jit_emit_call ("save_restriction_save", + gcc_jit_lvalue_as_rvalue (gcc_emit_call ("save_restriction_save", comp.lisp_obj_type, 0, NULL)); - jit_emit_call ("record_unwind_protect", comp.void_ptr_type, 2, args); + gcc_emit_call ("record_unwind_protect", comp.void_ptr_type, 2, args); break; case Bcatch: /* Obsolete since 24.4. */ @@ -793,12 +793,12 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, args[1] = gcc_jit_context_new_rvalue_from_ptr(comp.ctxt, comp.void_ptr_type, eval_sub); - jit_emit_call ("internal_catch", comp.void_ptr_type, 3, args); + gcc_emit_call ("internal_catch", comp.void_ptr_type, 3, args); break; case Bunwind_protect: /* FIXME: avoid closure for lexbind. */ POP1; - jit_emit_call ("helper_unwind_protect", comp.void_type, 1, args); + gcc_emit_call ("helper_unwind_protect", comp.void_type, 1, args); break; case Bcondition_case: commit 3943db1ab27a29105520bb4e2975e68540e3f055 Author: Andrea Corallo Date: Sat May 25 10:10:45 2019 +0200 adding more stuffs diff --git a/src/comp.c b/src/comp.c index a460d96050..3f7e093b57 100644 --- a/src/comp.c +++ b/src/comp.c @@ -28,6 +28,7 @@ along with GNU Emacs. If not, see . */ #include "buffer.h" #include "bytecode.h" #include "atimer.h" +#include "window.h" #define COMP_DEBUG 0 @@ -145,16 +146,16 @@ typedef struct { INLINE static void pop (unsigned n, gcc_jit_rvalue ***stack_ref, gcc_jit_rvalue *args[]); -static gcc_jit_function *jit_func_declare (const char *f_name, - gcc_jit_type *ret_type, - unsigned nargs, - gcc_jit_rvalue **args, - enum gcc_jit_function_kind kind, - bool reusable); - void emacs_native_compile (const char *lisp_f_name, const char *c_f_name, Lisp_Object func, bool dump_asm); + +static void +bcall0 (Lisp_Object f) +{ + Ffuncall (1, &f); +} + /* Pop form the main evaluation stack and place the elements in args in reversed order. */ @@ -683,6 +684,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, POP1; args[1] = comp.nil; res = jit_emit_call ("Findent_to", comp.lisp_obj_type, 2, args); + PUSH (gcc_jit_lvalue_as_rvalue (res)); break; CASE_CALL_NARGS (eolp, 0); @@ -706,43 +708,26 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, comp.void_type, 0, NULL); break; - case Binteractive_p: - error ("Binteractive_p not supported"); - break; - case Bforward_char: - error ("Bforward_char not supported"); - break; - case Bforward_word: - error ("Bforward_word not supported"); - break; - case Bskip_chars_forward: - error ("Bskip_chars_forward not supported"); - break; - case Bskip_chars_backward: - error ("Bskip_chars_backward not supported"); - break; - case Bforward_line: - error ("Bforward_line not supported"); - break; - case Bchar_syntax: - error ("Bchar_syntax not supported"); - break; - case Bbuffer_substring: - error ("Bbuffer_substring not supported"); - break; - case Bdelete_region: - error ("Bdelete_region not supported"); - break; - case Bnarrow_to_region: - error ("Bnarrow_to_region not supported"); - break; - case Bwiden: - error ("Bwiden not supported"); - break; - case Bend_of_line: - error ("Bend_of_line not supported"); + case Binteractive_p: /* Obsolete since 24.1. */ + PUSH (gcc_jit_context_new_rvalue_from_ptr(comp.ctxt, + comp.lisp_obj_type, + intern ("interactive-p"))); + res = jit_emit_call ("call0", comp.lisp_obj_type, 1, args); + PUSH (gcc_jit_lvalue_as_rvalue (res)); break; + CASE_CALL_NARGS (forward_char, 1); + CASE_CALL_NARGS (forward_word, 1); + CASE_CALL_NARGS (skip_chars_forward, 2); + CASE_CALL_NARGS (skip_chars_backward, 2); + CASE_CALL_NARGS (forward_line, 1); + CASE_CALL_NARGS (char_syntax, 1); + CASE_CALL_NARGS (buffer_substring, 2); + CASE_CALL_NARGS (delete_region, 2); + CASE_CALL_NARGS (narrow_to_region, 2); + CASE_CALL_NARGS (widen, 0); + CASE_CALL_NARGS (end_of_line, 1); + case Bconstant2: goto do_constant; break; @@ -779,20 +764,43 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, break; case Bsave_excursion: - error ("Bsave_excursion not supported"); + res = jit_emit_call ("record_unwind_protect_excursion", + comp.void_type, 0, args); break; - case Bsave_window_excursion: - error ("Bsave_window_excursion not supported"); + + case Bsave_window_excursion: /* Obsolete since 24.1. */ + POP1; + res = jit_emit_call ("helper_save_window_excursion", + comp.lisp_obj_type, 1, args); + PUSH (gcc_jit_lvalue_as_rvalue (res)); break; + case Bsave_restriction: - error ("Bsave_restriction not supported"); - break; - case Bcatch: - error ("Bcatch not supported"); - break; - case Bunwind_protect: - error ("Bunwind_protect not supported"); + args[0] = gcc_jit_context_new_rvalue_from_ptr(comp.ctxt, + comp.void_ptr_type, + save_restriction_restore); + args[1] = + gcc_jit_lvalue_as_rvalue (jit_emit_call ("save_restriction_save", + comp.lisp_obj_type, + 0, + NULL)); + jit_emit_call ("record_unwind_protect", comp.void_ptr_type, 2, args); + break; + + case Bcatch: /* Obsolete since 24.4. */ + POP2; + args[2] = args[1]; + args[1] = gcc_jit_context_new_rvalue_from_ptr(comp.ctxt, + comp.void_ptr_type, + eval_sub); + jit_emit_call ("internal_catch", comp.void_ptr_type, 3, args); + break; + + case Bunwind_protect: /* FIXME: avoid closure for lexbind. */ + POP1; + jit_emit_call ("helper_unwind_protect", comp.void_type, 1, args); break; + case Bcondition_case: error ("Bcondition_case not supported"); break; @@ -1139,4 +1147,31 @@ syms_of_comp (void) staticpro (&comp.func_hash); } +/******************************************************************************/ +/* Helper functions called from the runtime. */ +/* These can't be statics till shared mechanism is used to solve relocations. */ +/******************************************************************************/ + +Lisp_Object helper_save_window_excursion (Lisp_Object v1); + +void helper_unwind_protect (Lisp_Object handler); + +Lisp_Object +helper_save_window_excursion (Lisp_Object v1) +{ + ptrdiff_t count1 = SPECPDL_INDEX (); + record_unwind_protect (restore_window_configuration, + Fcurrent_window_configuration (Qnil)); + v1 = Fprogn (v1); + unbind_to (count1, v1); + return v1; +} + +void helper_unwind_protect (Lisp_Object handler) +{ + /* Support for a function here is new in 24.4. */ + record_unwind_protect (FUNCTIONP (handler) ? bcall0 : prog_ignore, + handler); +} + #endif /* HAVE_LIBJIT */ commit c6680e15d7c46b9c15358c5bcca4c70b3b2608be Author: Andrea Corallo Date: Sat May 25 09:44:06 2019 +0200 better error msg diff --git a/src/comp.c b/src/comp.c index 80c1c2a863..a460d96050 100644 --- a/src/comp.c +++ b/src/comp.c @@ -707,40 +707,40 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, break; case Binteractive_p: - error ("Binteractive_p\n"); + error ("Binteractive_p not supported"); break; case Bforward_char: - error ("Bforward_char\n"); + error ("Bforward_char not supported"); break; case Bforward_word: - error ("Bforward_word\n"); + error ("Bforward_word not supported"); break; case Bskip_chars_forward: - error ("Bskip_chars_forward\n"); + error ("Bskip_chars_forward not supported"); break; case Bskip_chars_backward: - error ("Bskip_chars_backward\n"); + error ("Bskip_chars_backward not supported"); break; case Bforward_line: - error ("Bforward_line\n"); + error ("Bforward_line not supported"); break; case Bchar_syntax: - error ("Bchar_syntax\n"); + error ("Bchar_syntax not supported"); break; case Bbuffer_substring: - error ("Bbuffer_substring\n"); + error ("Bbuffer_substring not supported"); break; case Bdelete_region: - error ("Bdelete_region\n"); + error ("Bdelete_region not supported"); break; case Bnarrow_to_region: - error ("Bnarrow_to_region\n"); + error ("Bnarrow_to_region not supported"); break; case Bwiden: - error ("Bwiden\n"); + error ("Bwiden not supported"); break; case Bend_of_line: - error ("Bend_of_line\n"); + error ("Bend_of_line not supported"); break; case Bconstant2: @@ -748,19 +748,19 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, break; case Bgoto: - error ("Bgoto\n"); + error ("Bgoto not supported"); break; case Bgotoifnil: - error ("Bgotoifnil\n"); + error ("Bgotoifnil not supported"); break; case Bgotoifnonnil: - error ("Bgotoifnonnil\n"); + error ("Bgotoifnonnil not supported"); break; case Bgotoifnilelsepop: - error ("Bgotoifnilelsepop\n"); + error ("Bgotoifnilelsepop not supported"); break; case Bgotoifnonnilelsepop: - error ("Bgotoifnonnilelsepop\n"); + error ("Bgotoifnonnilelsepop not supported"); break; case Breturn: @@ -779,127 +779,127 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, break; case Bsave_excursion: - error ("Bsave_excursion\n"); + error ("Bsave_excursion not supported"); break; case Bsave_window_excursion: - error ("Bsave_window_excursion\n"); + error ("Bsave_window_excursion not supported"); break; case Bsave_restriction: - error ("Bsave_restriction\n"); + error ("Bsave_restriction not supported"); break; case Bcatch: - error ("Bcatch\n"); + error ("Bcatch not supported"); break; case Bunwind_protect: - error ("Bunwind_protect\n"); + error ("Bunwind_protect not supported"); break; case Bcondition_case: - error ("Bcondition_case\n"); + error ("Bcondition_case not supported"); break; case Btemp_output_buffer_setup: - error ("Btemp_output_buffer_setup\n"); + error ("Btemp_output_buffer_setup not supported"); break; case Btemp_output_buffer_show: - error ("Btemp_output_buffer_show\n"); + error ("Btemp_output_buffer_show not supported"); break; case Bunbind_all: - error ("Bunbind_all\n"); + error ("Bunbind_all not supported"); break; case Bset_marker: - error ("Bset_marker\n"); + error ("Bset_marker not supported"); break; case Bmatch_beginning: - error ("Bmatch_beginning\n"); + error ("Bmatch_beginning not supported"); break; case Bmatch_end: - error ("Bmatch_end\n"); + error ("Bmatch_end not supported"); break; case Bupcase: - error ("Bupcase\n"); + error ("Bupcase not supported"); break; case Bdowncase: - error ("Bdowncase\n"); + error ("Bdowncase not supported"); break; case Bstringeqlsign: - error ("Bstringeqlsign\n"); + error ("Bstringeqlsign not supported"); break; case Bstringlss: - error ("Bstringlss\n"); + error ("Bstringlss not supported"); break; case Bequal: - error ("Bequal\n"); + error ("Bequal not supported"); break; case Bnthcdr: - error ("Bnthcdr\n"); + error ("Bnthcdr not supported"); break; case Belt: - error ("Belt\n"); + error ("Belt not supported"); break; case Bmember: - error ("Bmember\n"); + error ("Bmember not supported"); break; case Bassq: - error ("Bassq\n"); + error ("Bassq not supported"); break; case Bnreverse: - error ("Bnreverse\n"); + error ("Bnreverse not supported"); break; case Bsetcar: - error ("Bsetcar\n"); + error ("Bsetcar not supported"); break; case Bsetcdr: - error ("Bsetcdr\n"); + error ("Bsetcdr not supported"); break; case Bcar_safe: - error ("Bcar_safe\n"); + error ("Bcar_safe not supported"); break; case Bcdr_safe: - error ("Bcdr_safe\n"); + error ("Bcdr_safe not supported"); break; case Bnconc: - error ("Bnconc\n"); + error ("Bnconc not supported"); break; case Bquo: - error ("Bquo\n"); + error ("Bquo not supported"); break; case Brem: - error ("Brem\n"); + error ("Brem not supported"); break; case Bnumberp: - error ("Bnumberp\n"); + error ("Bnumberp not supported"); break; case Bintegerp: - error ("Bintegerp\n"); + error ("Bintegerp not supported"); break; case BRgoto: - error ("BRgoto\n"); + error ("BRgoto not supported"); break; case BRgotoifnil: - error ("BRgotoifnil\n"); + error ("BRgotoifnil not supported"); break; case BRgotoifnonnil: - error ("BRgotoifnonnil\n"); + error ("BRgotoifnonnil not supported"); break; case BRgotoifnilelsepop: - error ("BRgotoifnilelsepop\n"); + error ("BRgotoifnilelsepop not supported"); break; case BRgotoifnonnilelsepop: - error ("BRgotoifnonnilelsepop\n"); + error ("BRgotoifnonnilelsepop not supported"); break; case BinsertN: - error ("BinsertN\n"); + error ("BinsertN not supported"); break; case Bstack_set: - error ("Bstack_set\n"); + error ("Bstack_set not supported"); break; case Bstack_set2: - error ("Bstack_set2\n"); + error ("Bstack_set2 not supported"); break; case BdiscardN: - error ("BdiscardN\n"); + error ("BdiscardN not supported"); break; case Bswitch: - error ("Bswitch\n"); + error ("Bswitch not supported"); /* The cases of Bswitch that we handle (which in theory is all of them) are done in Bconstant, below. This is done due to a design issue with Bswitch -- it should have commit 1121416cfde99f0738d0dac63b6fdd2667de2c5e Author: Andrea Corallo Date: Fri May 24 18:01:02 2019 +0200 adding stuffs diff --git a/src/comp.c b/src/comp.c index 9b4dea98d7..80c1c2a863 100644 --- a/src/comp.c +++ b/src/comp.c @@ -117,10 +117,11 @@ along with GNU Emacs. If not, see . */ typedef struct { gcc_jit_context *ctxt; - gcc_jit_type *lisp_obj_type; + gcc_jit_type *void_type; gcc_jit_type *int_type; gcc_jit_type *void_ptr_type; gcc_jit_type *ptrdiff_type; + gcc_jit_type *lisp_obj_type; gcc_jit_function *func; /* Current function being compiled */ gcc_jit_rvalue *nil; gcc_jit_rvalue *scratch; /* Will point to scratch_call_area */ @@ -654,9 +655,6 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, case Bpoint: error ("Bpoint\n"); break; - case Bsave_current_buffer: - error ("Bsave_current_buffer\n"); - break; CASE_CALL_NARGS (goto_char, 1); @@ -682,29 +680,32 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, CASE_CALL_NARGS (current_column, 0); case Bindent_to: - error ("Bindent_to\n"); - break; - case Beolp: - error ("Beolp\n"); + POP1; + args[1] = comp.nil; + res = jit_emit_call ("Findent_to", comp.lisp_obj_type, 2, args); break; + + CASE_CALL_NARGS (eolp, 0); + case Beobp: error ("Beobp\n"); break; - case Bbolp: - error ("Bbolp\n"); - break; + + CASE_CALL_NARGS (bolp, 0); + case Bbobp: error ("Bbobp\n"); break; - case Bcurrent_buffer: - error ("Bcurrent_buffer\n"); - break; - case Bset_buffer: - error ("Bset_buffer\n"); - break; + + CASE_CALL_NARGS (current_buffer, 0); + CASE_CALL_NARGS (set_buffer, 1); + + case Bsave_current_buffer: /* Obsolete since ??. */ case Bsave_current_buffer_1: - error ("Bsave_current_buffer_1\n"); + jit_emit_call ("record_unwind_current_buffer", + comp.void_type, 0, NULL); break; + case Binteractive_p: error ("Binteractive_p\n"); break; @@ -1074,6 +1075,7 @@ init_comp (void) comp.lisp_obj_type = gcc_jit_context_get_type(comp.ctxt, GCC_JIT_TYPE_LONG_LONG); #endif + comp.void_type = gcc_jit_context_get_type(comp.ctxt, GCC_JIT_TYPE_VOID); comp.int_type = gcc_jit_context_get_type(comp.ctxt, GCC_JIT_TYPE_INT); comp.void_ptr_type = gcc_jit_context_get_type(comp.ctxt, GCC_JIT_TYPE_VOID_PTR); commit 15b4f9d8786d4ecc9eab81d114f09448de2b9ce9 Author: Andrea Corallo Date: Fri May 24 17:54:43 2019 +0200 precompute nil diff --git a/src/comp.c b/src/comp.c index 8cb7cbf4ad..9b4dea98d7 100644 --- a/src/comp.c +++ b/src/comp.c @@ -49,6 +49,8 @@ along with GNU Emacs. If not, see . */ stack++; \ } while (0) +#define POP0 + #define POP1 \ do { \ stack--; \ @@ -120,6 +122,7 @@ typedef struct { gcc_jit_type *void_ptr_type; gcc_jit_type *ptrdiff_type; gcc_jit_function *func; /* Current function being compiled */ + gcc_jit_rvalue *nil; gcc_jit_rvalue *scratch; /* Will point to scratch_call_area */ gcc_jit_block *block; /* Current basic block */ Lisp_Object func_hash; /* f_name -> gcc_func */ @@ -454,9 +457,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, args[0] = gcc_jit_context_new_rvalue_from_ptr(comp.ctxt, comp.lisp_obj_type, vectorp[op]); - args[2] = gcc_jit_context_new_rvalue_from_ptr(comp.ctxt, - comp.lisp_obj_type, - Qnil); + args[2] = comp.nil; args[3] = gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.int_type, SET_INTERNAL_SET); @@ -674,7 +675,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, CASE_CALL_NARGS (following_char, 0); case Bpreceding_char: - res = jit_emit_call (Fprevious_char, comp.lisp_obj_type, 0, args); + res = jit_emit_call ("Fprevious_char", comp.lisp_obj_type, 0, args); PUSH (gcc_jit_lvalue_as_rvalue (res)); break; @@ -1089,6 +1090,10 @@ init_comp (void) comp.ptrdiff_type = gcc_jit_context_get_type(comp.ctxt, ptrdiff_t_gcc); + comp.nil = gcc_jit_context_new_rvalue_from_ptr(comp.ctxt, + comp.lisp_obj_type, + Qnil); + comp.scratch = gcc_jit_lvalue_get_address( gcc_jit_context_new_global (comp.ctxt, NULL, commit 68472f45a6a441b1436b5949c0384dd57111077c Author: Andrea Corallo Date: Fri May 24 17:51:16 2019 +0200 some more ops diff --git a/src/comp.c b/src/comp.c index 4b01a05705..8cb7cbf4ad 100644 --- a/src/comp.c +++ b/src/comp.c @@ -669,18 +669,17 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, case Bpoint_min: error ("Bpoint_min\n"); break; - case Bchar_after: - error ("Bchar_after\n"); - break; - case Bfollowing_char: - error ("Bfollowing_char\n"); - break; + + CASE_CALL_NARGS (char_after, 1); + CASE_CALL_NARGS (following_char, 0); + case Bpreceding_char: - error ("Bpreceding_char\n"); - break; - case Bcurrent_column: - error ("Bcurrent_column\n"); + res = jit_emit_call (Fprevious_char, comp.lisp_obj_type, 0, args); + PUSH (gcc_jit_lvalue_as_rvalue (res)); break; + + CASE_CALL_NARGS (current_column, 0); + case Bindent_to: error ("Bindent_to\n"); break; commit a80140032be992d170925f274fad215de97d9a50 Author: Andrea Corallo Date: Fri May 24 17:38:02 2019 +0200 move return into the right place diff --git a/src/comp.c b/src/comp.c index 3f0db64666..4b01a05705 100644 --- a/src/comp.c +++ b/src/comp.c @@ -763,6 +763,10 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, break; case Breturn: + POP1; + gcc_jit_block_end_with_return(comp.block, + NULL, + args[0]); break; case Bdiscard: @@ -930,10 +934,6 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, } } - stack--; - gcc_jit_block_end_with_return(comp.block, - NULL, - *stack); comp_res.gcc_res = gcc_jit_context_compile(comp.ctxt); goto exit; commit 7e3d6657e7a952c2eaf9d814ac639613ec81ac1d Author: Andrea Corallo Date: Fri May 24 17:35:15 2019 +0200 replace printfs with proper errors for non supported ops diff --git a/src/comp.c b/src/comp.c index 259cba6691..3f0db64666 100644 --- a/src/comp.c +++ b/src/comp.c @@ -384,7 +384,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, while (pc < bytestr_length) { op = FETCH; - printf ("pc %td\t%ud\n", pc, op); + switch (op) { case Bstack_ref1: @@ -540,13 +540,13 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, } break; case Bpophandler: - printf("Bpophandler\n"); + error ("Bpophandler\n"); break; case Bpushconditioncase: - printf("Bpushconditioncase\n"); + error ("Bpushconditioncase\n"); break; case Bpushcatch: - printf("Bpushcatch\n"); + error ("Bpushcatch\n"); break; CASE_CALL_NARGS (nth, 2); @@ -612,31 +612,31 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, break; case Bsub1: - printf("Bsub1\n"); + error ("Bsub1\n"); break; case Badd1: - printf("Badd1\n"); + error ("Badd1\n"); break; case Beqlsign: - printf("Beqlsign\n"); + error ("Beqlsign\n"); break; case Bgtr: - printf("Bgtr\n"); + error ("Bgtr\n"); break; case Blss: - printf("Blss\n"); + error ("Blss\n"); break; case Bleq: - printf("Bleq\n"); + error ("Bleq\n"); break; case Bgeq: - printf("Bgeq\n"); + error ("Bgeq\n"); break; case Bdiff: EMIT_SCRATCH_CALL_N ("Fminus", 2); break; case Bnegate: - printf("Bnegate\n"); + error ("Bnegate\n"); break; case Bplus: EMIT_SCRATCH_CALL_N ("Fplus", 2); @@ -651,10 +651,10 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, EMIT_SCRATCH_CALL_N ("Ftimes", 2); break; case Bpoint: - printf("Bpoint\n"); + error ("Bpoint\n"); break; case Bsave_current_buffer: - printf("Bsave_current_buffer\n"); + error ("Bsave_current_buffer\n"); break; CASE_CALL_NARGS (goto_char, 1); @@ -664,104 +664,105 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, break; case Bpoint_max: - printf("Bpoint_max\n"); + error ("Bpoint_max\n"); break; case Bpoint_min: - printf("Bpoint_min\n"); + error ("Bpoint_min\n"); break; case Bchar_after: - printf("Bchar_after\n"); + error ("Bchar_after\n"); break; case Bfollowing_char: - printf("Bfollowing_char\n"); + error ("Bfollowing_char\n"); break; case Bpreceding_char: - printf("Bpreceding_char\n"); + error ("Bpreceding_char\n"); break; case Bcurrent_column: - printf("Bcurrent_column\n"); + error ("Bcurrent_column\n"); break; case Bindent_to: - printf("Bindent_to\n"); + error ("Bindent_to\n"); break; case Beolp: - printf("Beolp\n"); + error ("Beolp\n"); break; case Beobp: - printf("Beobp\n"); + error ("Beobp\n"); break; case Bbolp: - printf("Bbolp\n"); + error ("Bbolp\n"); break; case Bbobp: - printf("Bbobp\n"); + error ("Bbobp\n"); break; case Bcurrent_buffer: - printf("Bcurrent_buffer\n"); + error ("Bcurrent_buffer\n"); break; case Bset_buffer: - printf("Bset_buffer\n"); + error ("Bset_buffer\n"); break; case Bsave_current_buffer_1: - printf("Bsave_current_buffer_1\n"); + error ("Bsave_current_buffer_1\n"); break; case Binteractive_p: - printf("Binteractive_p\n"); + error ("Binteractive_p\n"); break; case Bforward_char: - printf("Bforward_char\n"); + error ("Bforward_char\n"); break; case Bforward_word: - printf("Bforward_word\n"); + error ("Bforward_word\n"); break; case Bskip_chars_forward: - printf("Bskip_chars_forward\n"); + error ("Bskip_chars_forward\n"); break; case Bskip_chars_backward: - printf("Bskip_chars_backward\n"); + error ("Bskip_chars_backward\n"); break; case Bforward_line: - printf("Bforward_line\n"); + error ("Bforward_line\n"); break; case Bchar_syntax: - printf("Bchar_syntax\n"); + error ("Bchar_syntax\n"); break; case Bbuffer_substring: - printf("Bbuffer_substring\n"); + error ("Bbuffer_substring\n"); break; case Bdelete_region: - printf("Bdelete_region\n"); + error ("Bdelete_region\n"); break; case Bnarrow_to_region: - printf("Bnarrow_to_region\n"); + error ("Bnarrow_to_region\n"); break; case Bwiden: - printf("Bwiden\n"); + error ("Bwiden\n"); break; case Bend_of_line: - printf("Bend_of_line\n"); + error ("Bend_of_line\n"); break; + case Bconstant2: - printf("Bconstant2\n"); goto do_constant; break; + case Bgoto: - printf("Bgoto\n"); + error ("Bgoto\n"); break; case Bgotoifnil: - printf("Bgotoifnil\n"); + error ("Bgotoifnil\n"); break; case Bgotoifnonnil: - printf("Bgotoifnonnil\n"); + error ("Bgotoifnonnil\n"); break; case Bgotoifnilelsepop: - printf("Bgotoifnilelsepop\n"); + error ("Bgotoifnilelsepop\n"); break; case Bgotoifnonnilelsepop: - printf("Bgotoifnonnilelsepop\n"); + error ("Bgotoifnonnilelsepop\n"); break; + case Breturn: - printf("Breturn\n"); break; case Bdiscard: @@ -773,127 +774,127 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, break; case Bsave_excursion: - printf("Bsave_excursion\n"); + error ("Bsave_excursion\n"); break; case Bsave_window_excursion: - printf("Bsave_window_excursion\n"); + error ("Bsave_window_excursion\n"); break; case Bsave_restriction: - printf("Bsave_restriction\n"); + error ("Bsave_restriction\n"); break; case Bcatch: - printf("Bcatch\n"); + error ("Bcatch\n"); break; case Bunwind_protect: - printf("Bunwind_protect\n"); + error ("Bunwind_protect\n"); break; case Bcondition_case: - printf("Bcondition_case\n"); + error ("Bcondition_case\n"); break; case Btemp_output_buffer_setup: - printf("Btemp_output_buffer_setup\n"); + error ("Btemp_output_buffer_setup\n"); break; case Btemp_output_buffer_show: - printf("Btemp_output_buffer_show\n"); + error ("Btemp_output_buffer_show\n"); break; case Bunbind_all: - printf("Bunbind_all\n"); + error ("Bunbind_all\n"); break; case Bset_marker: - printf("Bset_marker\n"); + error ("Bset_marker\n"); break; case Bmatch_beginning: - printf("Bmatch_beginning\n"); + error ("Bmatch_beginning\n"); break; case Bmatch_end: - printf("Bmatch_end\n"); + error ("Bmatch_end\n"); break; case Bupcase: - printf("Bupcase\n"); + error ("Bupcase\n"); break; case Bdowncase: - printf("Bdowncase\n"); + error ("Bdowncase\n"); break; case Bstringeqlsign: - printf("Bstringeqlsign\n"); + error ("Bstringeqlsign\n"); break; case Bstringlss: - printf("Bstringlss\n"); + error ("Bstringlss\n"); break; case Bequal: - printf("Bequal\n"); + error ("Bequal\n"); break; case Bnthcdr: - printf("Bnthcdr\n"); + error ("Bnthcdr\n"); break; case Belt: - printf("Belt\n"); + error ("Belt\n"); break; case Bmember: - printf("Bmember\n"); + error ("Bmember\n"); break; case Bassq: - printf("Bassq\n"); + error ("Bassq\n"); break; case Bnreverse: - printf("Bnreverse\n"); + error ("Bnreverse\n"); break; case Bsetcar: - printf("Bsetcar\n"); + error ("Bsetcar\n"); break; case Bsetcdr: - printf("Bsetcdr\n"); + error ("Bsetcdr\n"); break; case Bcar_safe: - printf("Bcar_safe\n"); + error ("Bcar_safe\n"); break; case Bcdr_safe: - printf("Bcdr_safe\n"); + error ("Bcdr_safe\n"); break; case Bnconc: - printf("Bnconc\n"); + error ("Bnconc\n"); break; case Bquo: - printf("Bquo\n"); + error ("Bquo\n"); break; case Brem: - printf("Brem\n"); + error ("Brem\n"); break; case Bnumberp: - printf("Bnumberp\n"); + error ("Bnumberp\n"); break; case Bintegerp: - printf("Bintegerp\n"); + error ("Bintegerp\n"); break; case BRgoto: - printf("BRgoto\n"); + error ("BRgoto\n"); break; case BRgotoifnil: - printf("BRgotoifnil\n"); + error ("BRgotoifnil\n"); break; case BRgotoifnonnil: - printf("BRgotoifnonnil\n"); + error ("BRgotoifnonnil\n"); break; case BRgotoifnilelsepop: - printf("BRgotoifnilelsepop\n"); + error ("BRgotoifnilelsepop\n"); break; case BRgotoifnonnilelsepop: - printf("BRgotoifnonnilelsepop\n"); + error ("BRgotoifnonnilelsepop\n"); break; case BinsertN: - printf("BinsertN\n"); + error ("BinsertN\n"); break; case Bstack_set: - printf("Bstack_set\n"); + error ("Bstack_set\n"); break; case Bstack_set2: - printf("Bstack_set2\n"); + error ("Bstack_set2\n"); break; case BdiscardN: - printf("BdiscardN\n"); + error ("BdiscardN\n"); break; case Bswitch: - printf("Bswitch\n"); + error ("Bswitch\n"); /* The cases of Bswitch that we handle (which in theory is all of them) are done in Bconstant, below. This is done due to a design issue with Bswitch -- it should have @@ -903,7 +904,6 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, break; default: case Bconstant: - printf("Bconstant "); { if (op < Bconstant || op > Bconstant + vector_size) goto fail; @@ -919,7 +919,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, comp.lisp_obj_type, vectorp[op]); PUSH (c); - Fprint(vectorp[op], Qnil); + /* Fprint(vectorp[op], Qnil); */ break; } commit 7ad90d410813dae9d2fda3c251d14678b8f104d0 Author: Andrea Corallo Date: Fri May 24 17:26:54 2019 +0200 add some more ops diff --git a/src/comp.c b/src/comp.c index 8745908708..259cba6691 100644 --- a/src/comp.c +++ b/src/comp.c @@ -633,22 +633,22 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, printf("Bgeq\n"); break; case Bdiff: - printf("Bdiff\n"); + EMIT_SCRATCH_CALL_N ("Fminus", 2); break; case Bnegate: printf("Bnegate\n"); break; case Bplus: - printf("Bplus\n"); + EMIT_SCRATCH_CALL_N ("Fplus", 2); break; case Bmax: - printf("Bmax\n"); + EMIT_SCRATCH_CALL_N ("Fmax", 2); break; case Bmin: - printf("Bmin\n"); + EMIT_SCRATCH_CALL_N ("Fmin", 2); break; case Bmult: - printf("Bmult\n"); + EMIT_SCRATCH_CALL_N ("Ftimes", 2); break; case Bpoint: printf("Bpoint\n"); @@ -656,12 +656,13 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, case Bsave_current_buffer: printf("Bsave_current_buffer\n"); break; - case Bgoto_char: - printf("Bgoto_char\n"); - break; + + CASE_CALL_NARGS (goto_char, 1); + case Binsert: - printf("Binsert\n"); + EMIT_SCRATCH_CALL_N ("Finsert", 1); break; + case Bpoint_max: printf("Bpoint_max\n"); break; commit a5524504164ed9077984b90ecf5067d1e8bcbdb2 Author: Andrea Corallo Date: Fri May 24 16:57:55 2019 +0200 add concat diff --git a/src/comp.c b/src/comp.c index 2e5f3342cb..8745908708 100644 --- a/src/comp.c +++ b/src/comp.c @@ -91,8 +91,10 @@ along with GNU Emacs. If not, see . */ #define STR(s) #s -/* With most of the ops we need to do the same stuff so this save some - typing. */ +/* With most of the ops we need to do the same stuff so this macros are meant + to save some typing. */ + +/* Generate appropriate case and emit convential calls to function. */ #define CASE_CALL_NARGS(name, nargs) \ case B##name: \ @@ -101,6 +103,14 @@ along with GNU Emacs. If not, see . */ PUSH (gcc_jit_lvalue_as_rvalue (res)); \ break +/* Emit calls to functions with prototype (ptrdiff_t nargs, Lisp_Object *args) + This is done aggregating args into the scratch_call_area. */ + +#define EMIT_SCRATCH_CALL_N(name, nargs) \ + pop (nargs, &stack, args); \ + res = jit_emit_callN (name, nargs, args); \ + PUSH (gcc_jit_lvalue_as_rvalue (res)) + /* The compiler context */ typedef struct { @@ -588,14 +598,19 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, CASE_CALL_NARGS (substring, 3); case Bconcat2: - printf("Bconcat2\n"); + EMIT_SCRATCH_CALL_N ("Fconcat", 2); break; case Bconcat3: - printf("Bconcat3\n"); + EMIT_SCRATCH_CALL_N ("Fconcat", 3); break; case Bconcat4: - printf("Bconcat4\n"); + EMIT_SCRATCH_CALL_N ("Fconcat", 4); break; + case BconcatN: + op = FETCH; + EMIT_SCRATCH_CALL_N ("Fconcat", op); + break; + case Bsub1: printf("Bsub1\n"); break; @@ -864,9 +879,6 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, case BRgotoifnonnilelsepop: printf("BRgotoifnonnilelsepop\n"); break; - case BconcatN: - printf("BconcatN\n"); - break; case BinsertN: printf("BinsertN\n"); break; diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 36344d361f..006336393d 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -106,6 +106,15 @@ (should (= (comp-tests-symbol-value-f) 3))) +(ert-deftest comp-tests-concat () + "Testing concatX opcodes." + (defun comp-tests-concat-f (x) + (concat "a" "b" "c" "d" + (concat "a" "b" "c" (concat "a" "b" (concat "foo" x))))) + (byte-compile #'comp-tests-concat-f) + (native-compile #'comp-tests-concat-f) + + (should (string= (comp-tests-concat-f "bar") "abcdabcabfoobar"))) (ert-deftest comp-tests-ffuncall () "Testing varset." commit 2a5c81a5c92d15e8db471d16f3a014a338f9c271 Author: Andrea Corallo Date: Fri May 24 16:32:25 2019 +0200 store ffuncall with all other functions diff --git a/src/comp.c b/src/comp.c index feec3c965e..2e5f3342cb 100644 --- a/src/comp.c +++ b/src/comp.c @@ -110,7 +110,6 @@ typedef struct { gcc_jit_type *void_ptr_type; gcc_jit_type *ptrdiff_type; gcc_jit_function *func; /* Current function being compiled */ - gcc_jit_function *Ffuncall; /* Current function being compiled */ gcc_jit_rvalue *scratch; /* Will point to scratch_call_area */ gcc_jit_block *block; /* Current basic block */ Lisp_Object func_hash; /* f_name -> gcc_func */ @@ -273,8 +272,7 @@ jit_emit_call (const char *f_name, gcc_jit_type *ret_type, unsigned nargs, } static gcc_jit_lvalue * -jit_emit_callN (gcc_jit_function *func, unsigned nargs, - gcc_jit_rvalue **args) +jit_emit_callN (const char *f_name, unsigned nargs, gcc_jit_rvalue **args) { /* Here we set all the pointers into the scratch call area. */ /* TODO: distinguish primitives for faster calling convention. */ @@ -320,18 +318,7 @@ jit_emit_callN (gcc_jit_function *func, unsigned nargs, nargs); args[1] = comp.scratch; - gcc_jit_lvalue *res = gcc_jit_function_new_local(comp.func, - NULL, - comp.lisp_obj_type, - "res"); - gcc_jit_block_add_assignment(comp.block, NULL, - res, - gcc_jit_context_new_call(comp.ctxt, - NULL, - func, - 2, - args)); - return res; + return jit_emit_call (f_name, comp.lisp_obj_type, 2, args); } static comp_f_res_t @@ -513,7 +500,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, { ptrdiff_t nargs = op + 1; pop (nargs, &stack, args); - res = jit_emit_callN (comp.Ffuncall, nargs, args); + res = jit_emit_callN ("Ffuncall", nargs, args); PUSH (gcc_jit_lvalue_as_rvalue (res)); break; } @@ -1090,25 +1077,6 @@ init_comp (void) comp.ptrdiff_type = gcc_jit_context_get_type(comp.ctxt, ptrdiff_t_gcc); - gcc_jit_param *funcall_param[2] = { - gcc_jit_context_new_param(comp.ctxt, - NULL, - comp.ptrdiff_type, - "nargs"), - gcc_jit_context_new_param(comp.ctxt, - NULL, - gcc_jit_type_get_pointer (comp.lisp_obj_type), - "args") }; - - comp.Ffuncall = - gcc_jit_context_new_function(comp.ctxt, NULL, - GCC_JIT_FUNCTION_IMPORTED, - comp.lisp_obj_type, - "Ffuncall", - 2, - funcall_param, - 0); - comp.scratch = gcc_jit_lvalue_get_address( gcc_jit_context_new_global (comp.ctxt, NULL, commit 6ce8092a01519acd2afe29a68b11809280677ad7 Author: Andrea Corallo Date: Fri May 24 16:08:52 2019 +0200 add jit_emit_callN diff --git a/src/comp.c b/src/comp.c index d8a5545d6e..feec3c965e 100644 --- a/src/comp.c +++ b/src/comp.c @@ -273,7 +273,8 @@ jit_emit_call (const char *f_name, gcc_jit_type *ret_type, unsigned nargs, } static gcc_jit_lvalue * -jit_emit_Ffuncall (unsigned nargs, gcc_jit_rvalue **args) +jit_emit_callN (gcc_jit_function *func, unsigned nargs, + gcc_jit_rvalue **args) { /* Here we set all the pointers into the scratch call area. */ /* TODO: distinguish primitives for faster calling convention. */ @@ -327,7 +328,7 @@ jit_emit_Ffuncall (unsigned nargs, gcc_jit_rvalue **args) res, gcc_jit_context_new_call(comp.ctxt, NULL, - comp.Ffuncall, + func, 2, args)); return res; @@ -512,7 +513,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, { ptrdiff_t nargs = op + 1; pop (nargs, &stack, args); - res = jit_emit_Ffuncall (nargs, args); + res = jit_emit_callN (comp.Ffuncall, nargs, args); PUSH (gcc_jit_lvalue_as_rvalue (res)); break; } commit 28cd3abbdf24660d8c3587ee983037f82058b87c Author: Andrea Corallo Date: Fri May 24 16:05:41 2019 +0200 rationalize jit_emit_Ffuncall diff --git a/src/comp.c b/src/comp.c index eecfd5121c..d8a5545d6e 100644 --- a/src/comp.c +++ b/src/comp.c @@ -275,15 +275,15 @@ jit_emit_call (const char *f_name, gcc_jit_type *ret_type, unsigned nargs, static gcc_jit_lvalue * jit_emit_Ffuncall (unsigned nargs, gcc_jit_rvalue **args) { - /* Here we set all the pointers into the scratch call area. */ - /* TODO: distinguish primitive for faster call convention. */ + /* TODO: distinguish primitives for faster calling convention. */ /* Lisp_Object *p; p = scratch_call_area; - p[0] = 0x...; + p[0] = nargs; + p[1] = 0x...; . . . @@ -311,9 +311,12 @@ jit_emit_Ffuncall (unsigned nargs, gcc_jit_rvalue **args) NULL, gcc_jit_lvalue_as_rvalue(p), idx), - args[i + 1]); + args[i]); } + args[0] = gcc_jit_context_new_rvalue_from_int(comp.ctxt, + comp.ptrdiff_type, + nargs); args[1] = comp.scratch; gcc_jit_lvalue *res = gcc_jit_function_new_local(comp.func, @@ -508,12 +511,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, docall: { ptrdiff_t nargs = op + 1; - - args[0] = gcc_jit_context_new_rvalue_from_int(comp.ctxt, - comp.ptrdiff_type, - nargs); - pop (nargs, &stack, &args[1]); - + pop (nargs, &stack, args); res = jit_emit_Ffuncall (nargs, args); PUSH (gcc_jit_lvalue_as_rvalue (res)); break; commit 38a5a36a17578a5e06ab18986ce6dae68938e1be Author: Andrea Corallo Date: Fri May 24 15:53:09 2019 +0200 some more ops diff --git a/src/comp.c b/src/comp.c index 07629fa00b..eecfd5121c 100644 --- a/src/comp.c +++ b/src/comp.c @@ -552,29 +552,15 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, case Bpushcatch: printf("Bpushcatch\n"); break; - case Bnth: - printf("Bnth\n"); - break; - case Bsymbolp: - printf("Bsymbolp\n"); - break; - case Bconsp: - printf("Bconsp\n"); - break; - case Bstringp: - printf("Bstringp\n"); - break; - case Blistp: - printf("Blistp\n"); - break; + CASE_CALL_NARGS (nth, 2); + CASE_CALL_NARGS (symbolp, 1); + CASE_CALL_NARGS (consp, 1); + CASE_CALL_NARGS (stringp, 1); + CASE_CALL_NARGS (listp, 1); CASE_CALL_NARGS (eq, 2); CASE_CALL_NARGS (memq, 1); - - case Bnot: - printf("Bnot\n"); - break; - + CASE_CALL_NARGS (not, 1); CASE_CALL_NARGS (car, 1); CASE_CALL_NARGS (cdr, 1); CASE_CALL_NARGS (cons, 2); @@ -612,9 +598,8 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, CASE_CALL_NARGS (symbol_function, 1); CASE_CALL_NARGS (set, 2); CASE_CALL_NARGS (fset, 2); - CASE_CALL_NARGS (fget, 2); - CASE_CALL_NARGS (fget, 2); - CASE_CALL_NARGS (Bsubstring, 3); + CASE_CALL_NARGS (get, 2); + CASE_CALL_NARGS (substring, 3); case Bconcat2: printf("Bconcat2\n"); commit f42b2b0143f5f6e6fd9741b482cd98785feb95da Author: Andrea Corallo Date: Fri May 24 15:43:00 2019 +0200 introduce CASE_CALL_NARGS macro and add various ops symbol_function set fset fget fget Bsubstring diff --git a/src/comp.c b/src/comp.c index 33528f9800..07629fa00b 100644 --- a/src/comp.c +++ b/src/comp.c @@ -89,6 +89,18 @@ along with GNU Emacs. If not, see . */ #define DISCARD(n) (stack -= (n)) +#define STR(s) #s + +/* With most of the ops we need to do the same stuff so this save some + typing. */ + +#define CASE_CALL_NARGS(name, nargs) \ + case B##name: \ + POP##nargs; \ + res = jit_emit_call (STR(F##name), comp.lisp_obj_type, nargs, args); \ + PUSH (gcc_jit_lvalue_as_rvalue (res)); \ + break + /* The compiler context */ typedef struct { @@ -555,35 +567,17 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, case Blistp: printf("Blistp\n"); break; - case Beq: - POP2; - res = jit_emit_call ("Feq", comp.lisp_obj_type, 2, args); - PUSH (gcc_jit_lvalue_as_rvalue (res)); - break; - case Bmemq: - POP1; - res = jit_emit_call ("Fmemq", comp.lisp_obj_type, 1, args); - PUSH (gcc_jit_lvalue_as_rvalue (res)); - break; - break; + + CASE_CALL_NARGS (eq, 2); + CASE_CALL_NARGS (memq, 1); + case Bnot: printf("Bnot\n"); break; - case Bcar: - POP1; - res = jit_emit_call ("Fcar", comp.lisp_obj_type, 1, args); - PUSH (gcc_jit_lvalue_as_rvalue (res)); - break; - case Bcdr: - POP1; - res = jit_emit_call ("Fcdr", comp.lisp_obj_type, 1, args); - PUSH (gcc_jit_lvalue_as_rvalue (res)); - break; - case Bcons: - POP2; - res = jit_emit_call ("Fcons", comp.lisp_obj_type, 2, args); - PUSH (gcc_jit_lvalue_as_rvalue (res)); - break; + + CASE_CALL_NARGS (car, 1); + CASE_CALL_NARGS (cdr, 1); + CASE_CALL_NARGS (cons, 2); case BlistN: op = FETCH; @@ -611,45 +605,17 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, break; } - case Blength: - POP1; - res = jit_emit_call ("Flength", comp.lisp_obj_type, 1, args); - PUSH (gcc_jit_lvalue_as_rvalue (res)); - break; - - case Baref: - POP2; - res = jit_emit_call ("Faref", comp.lisp_obj_type, 2, args); - PUSH (gcc_jit_lvalue_as_rvalue (res)); - break; - - case Baset: - POP3; - res = jit_emit_call ("Faset", comp.lisp_obj_type, 3, args); - PUSH (gcc_jit_lvalue_as_rvalue (res)); - break; - - case Bsymbol_value: - POP1; - res = jit_emit_call ("Fsymbol_value", comp.lisp_obj_type, 1, args); - PUSH (gcc_jit_lvalue_as_rvalue (res)); - break; + CASE_CALL_NARGS (length, 1); + CASE_CALL_NARGS (aref, 2); + CASE_CALL_NARGS (aset, 3); + CASE_CALL_NARGS (symbol_value, 1); + CASE_CALL_NARGS (symbol_function, 1); + CASE_CALL_NARGS (set, 2); + CASE_CALL_NARGS (fset, 2); + CASE_CALL_NARGS (fget, 2); + CASE_CALL_NARGS (fget, 2); + CASE_CALL_NARGS (Bsubstring, 3); - case Bsymbol_function: - printf("Bsymbol_function\n"); - break; - case Bset: - printf("Bset\n"); - break; - case Bfset: - printf("Bfset\n"); - break; - case Bget: - printf("Bget\n"); - break; - case Bsubstring: - printf("Bsubstring\n"); - break; case Bconcat2: printf("Bconcat2\n"); break; commit 17807af213da9eb08507d47dff142a1f8672b4e7 Author: Andrea Corallo Date: Fri May 24 15:00:34 2019 +0200 add symbol-value diff --git a/src/comp.c b/src/comp.c index 2e7ef4f077..33528f9800 100644 --- a/src/comp.c +++ b/src/comp.c @@ -630,8 +630,11 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, break; case Bsymbol_value: - printf("Bsymbol_value\n"); + POP1; + res = jit_emit_call ("Fsymbol_value", comp.lisp_obj_type, 1, args); + PUSH (gcc_jit_lvalue_as_rvalue (res)); break; + case Bsymbol_function: printf("Bsymbol_function\n"); break; diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 769cd086b5..36344d361f 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -96,6 +96,17 @@ (should (= (comp-tests-aref-aset-f) 100))) +(ert-deftest comp-tests-symbol-value () + "Testing aref and aset." + (defvar comp-tests-var2 3) + (defun comp-tests-symbol-value-f () + (symbol-value 'comp-tests-var2)) + (byte-compile #'comp-tests-symbol-value-f) + (native-compile #'comp-tests-symbol-value-f) + + (should (= (comp-tests-symbol-value-f) 3))) + + (ert-deftest comp-tests-ffuncall () "Testing varset." (defun comp-tests-ffuncall-callee-f (x y z) commit bebd14acc1f646c79702fca4f7081df30a49a66c Author: Andrea Corallo Date: Fri May 24 14:48:55 2019 +0200 add aset diff --git a/src/comp.c b/src/comp.c index 5f250c8143..2e7ef4f077 100644 --- a/src/comp.c +++ b/src/comp.c @@ -624,8 +624,11 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, break; case Baset: - printf("Baset\n"); + POP3; + res = jit_emit_call ("Faset", comp.lisp_obj_type, 3, args); + PUSH (gcc_jit_lvalue_as_rvalue (res)); break; + case Bsymbol_value: printf("Bsymbol_value\n"); break; diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index be131f7de7..769cd086b5 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -85,14 +85,16 @@ (should (= (comp-tests-length-f) 3))) -(ert-deftest comp-tests-aref () - "Testing aref." - (defun comp-tests-aref-f () - (aref [1 2 3] 2)) - (byte-compile #'comp-tests-aref-f) - (native-compile #'comp-tests-aref-f) - - (should (= (comp-tests-aref-f) 3))) +(ert-deftest comp-tests-aref-aset () + "Testing aref and aset." + (defun comp-tests-aref-aset-f () + (let ((vec [1 2 3])) + (aset vec 2 100) + (aref vec 2))) + (byte-compile #'comp-tests-aref-aset-f) + (native-compile #'comp-tests-aref-aset-f) + + (should (= (comp-tests-aref-aset-f) 100))) (ert-deftest comp-tests-ffuncall () "Testing varset." commit 770e52e7001ccdd309a47cbf8b8c9862bfd44ab5 Author: Andrea Corallo Date: Fri May 24 14:48:24 2019 +0200 add discard and dup diff --git a/src/comp.c b/src/comp.c index bafb980dc6..5f250c8143 100644 --- a/src/comp.c +++ b/src/comp.c @@ -85,6 +85,10 @@ along with GNU Emacs. If not, see . */ #define FETCH2 (op = FETCH, op + (FETCH << 8)) +/* Discard n values from the stack. */ + +#define DISCARD(n) (stack -= (n)) + /* The compiler context */ typedef struct { @@ -800,12 +804,15 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, case Breturn: printf("Breturn\n"); break; + case Bdiscard: - printf("Bdiscard\n"); + DISCARD (1); break; + case Bdup: - printf("Bdup\n"); + PUSH (*(stack - 1)); break; + case Bsave_excursion: printf("Bsave_excursion\n"); break; commit 2b48e5f979610de9c92df24d7cc6c47b6d8d83da Author: Andrea Corallo Date: Fri May 24 14:10:09 2019 +0200 Baref diff --git a/src/comp.c b/src/comp.c index 198343c057..bafb980dc6 100644 --- a/src/comp.c +++ b/src/comp.c @@ -612,9 +612,13 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, res = jit_emit_call ("Flength", comp.lisp_obj_type, 1, args); PUSH (gcc_jit_lvalue_as_rvalue (res)); break; + case Baref: - printf("Baref\n"); + POP2; + res = jit_emit_call ("Faref", comp.lisp_obj_type, 2, args); + PUSH (gcc_jit_lvalue_as_rvalue (res)); break; + case Baset: printf("Baset\n"); break; diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 32d5b50e13..be131f7de7 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -85,6 +85,15 @@ (should (= (comp-tests-length-f) 3))) +(ert-deftest comp-tests-aref () + "Testing aref." + (defun comp-tests-aref-f () + (aref [1 2 3] 2)) + (byte-compile #'comp-tests-aref-f) + (native-compile #'comp-tests-aref-f) + + (should (= (comp-tests-aref-f) 3))) + (ert-deftest comp-tests-ffuncall () "Testing varset." (defun comp-tests-ffuncall-callee-f (x y z) commit 5a9d4d67043e86831df9c8b3dcb398c45b01bb06 Author: Andrea Corallo Date: Fri May 24 14:01:45 2019 +0200 add Blength diff --git a/src/comp.c b/src/comp.c index 657fb2630e..198343c057 100644 --- a/src/comp.c +++ b/src/comp.c @@ -608,7 +608,9 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, } case Blength: - printf("Blength\n"); + POP1; + res = jit_emit_call ("Flength", comp.lisp_obj_type, 1, args); + PUSH (gcc_jit_lvalue_as_rvalue (res)); break; case Baref: printf("Baref\n"); diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 313f6906cd..32d5b50e13 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -76,6 +76,15 @@ (should (= comp-tests-var1 55))) +(ert-deftest comp-tests-length () + "Testing length." + (defun comp-tests-length-f () + (length '(1 2 3))) + (byte-compile #'comp-tests-length-f) + (native-compile #'comp-tests-length-f) + + (should (= (comp-tests-length-f) 3))) + (ert-deftest comp-tests-ffuncall () "Testing varset." (defun comp-tests-ffuncall-callee-f (x y z) commit f4d2f75a0782c53bfb09b70bc75de3c974ae5002 Author: Andrea Corallo Date: Fri May 24 13:07:11 2019 +0200 add void ptr diff --git a/src/comp.c b/src/comp.c index 53cb54cba8..657fb2630e 100644 --- a/src/comp.c +++ b/src/comp.c @@ -91,6 +91,7 @@ typedef struct { gcc_jit_context *ctxt; gcc_jit_type *lisp_obj_type; gcc_jit_type *int_type; + gcc_jit_type *void_ptr_type; gcc_jit_type *ptrdiff_type; gcc_jit_function *func; /* Current function being compiled */ gcc_jit_function *Ffuncall; /* Current function being compiled */ @@ -1105,6 +1106,8 @@ init_comp (void) #endif comp.int_type = gcc_jit_context_get_type(comp.ctxt, GCC_JIT_TYPE_INT); + comp.void_ptr_type = + gcc_jit_context_get_type(comp.ctxt, GCC_JIT_TYPE_VOID_PTR); enum gcc_jit_types ptrdiff_t_gcc; if (sizeof (ptrdiff_t) == sizeof (int)) commit b21539f6083bb7be6ce3b7d7701b270bc0bf384b Author: Andrea Corallo Date: Fri May 24 12:24:44 2019 +0200 generalize lisp call ret type diff --git a/src/comp.c b/src/comp.c index e7a8b9b0e9..53cb54cba8 100644 --- a/src/comp.c +++ b/src/comp.c @@ -115,7 +115,9 @@ typedef struct { INLINE static void pop (unsigned n, gcc_jit_rvalue ***stack_ref, gcc_jit_rvalue *args[]); -static gcc_jit_function *jit_func_declare (const char *f_name, unsigned nargs, +static gcc_jit_function *jit_func_declare (const char *f_name, + gcc_jit_type *ret_type, + unsigned nargs, gcc_jit_rvalue **args, enum gcc_jit_function_kind kind, bool reusable); @@ -141,7 +143,8 @@ pop (unsigned n, gcc_jit_rvalue ***stack_ref, gcc_jit_rvalue *args[]) } static gcc_jit_function * -jit_func_declare (const char *f_name, unsigned nargs, gcc_jit_rvalue **args, +jit_func_declare (const char *f_name, gcc_jit_type *ret_type, + unsigned nargs, gcc_jit_rvalue **args, enum gcc_jit_function_kind kind, bool reusable) { gcc_jit_param *param[4]; @@ -219,7 +222,8 @@ jit_func_declare (const char *f_name, unsigned nargs, gcc_jit_rvalue **args, } static gcc_jit_lvalue * -jit_emit_call (const char *f_name, unsigned nargs, gcc_jit_rvalue **args) +jit_emit_call (const char *f_name, gcc_jit_type *ret_type, unsigned nargs, + gcc_jit_rvalue **args) { Lisp_Object key = make_string (f_name, strlen (f_name)); EMACS_UINT hash = 0; @@ -228,7 +232,7 @@ jit_emit_call (const char *f_name, unsigned nargs, gcc_jit_rvalue **args) if (i == -1) { - jit_func_declare(f_name, nargs, args, GCC_JIT_FUNCTION_IMPORTED, + jit_func_declare(f_name, ret_type, nargs, args, GCC_JIT_FUNCTION_IMPORTED, true); i = hash_lookup (ht, key, &hash); eassert (i != -1); @@ -239,7 +243,7 @@ jit_emit_call (const char *f_name, unsigned nargs, gcc_jit_rvalue **args) gcc_jit_lvalue *res = gcc_jit_function_new_local(comp.func, NULL, - comp.lisp_obj_type, + ret_type, "res"); gcc_jit_block_add_assignment(comp.block, NULL, res, @@ -351,8 +355,8 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, /* Current function being compiled. Return a lips obj. */ - comp.func = jit_func_declare (f_name, comp_res.max_args, NULL, - GCC_JIT_FUNCTION_EXPORTED, false); + comp.func = jit_func_declare (f_name, comp.lisp_obj_type, comp_res.max_args, + NULL, GCC_JIT_FUNCTION_EXPORTED, false); for (ptrdiff_t i = 0; i < comp_res.max_args; ++i) PUSH (gcc_jit_param_as_rvalue (gcc_jit_function_get_param (comp.func, i))); @@ -405,7 +409,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, args[0] = gcc_jit_context_new_rvalue_from_ptr(comp.ctxt, comp.lisp_obj_type, vectorp[op]); - res = jit_emit_call ("Fsymbol_value", 1, args); + res = jit_emit_call ("Fsymbol_value", comp.lisp_obj_type, 1, args); PUSH (gcc_jit_lvalue_as_rvalue (res)); break; } @@ -438,7 +442,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, args[3] = gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.int_type, SET_INTERNAL_SET); - res = jit_emit_call ("set_internal", 4, args); + res = jit_emit_call ("set_internal", comp.lisp_obj_type, 4, args); PUSH (gcc_jit_lvalue_as_rvalue (res)); } break; @@ -464,7 +468,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, comp.lisp_obj_type, vectorp[op]); pop (1, &stack, &args[1]); - res = jit_emit_call ("specbind", 2, args); + res = jit_emit_call ("specbind", comp.lisp_obj_type, 2, args); PUSH (gcc_jit_lvalue_as_rvalue (res)); break; } @@ -519,7 +523,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, comp.ptrdiff_type, op); - res = jit_emit_call ("unbind_n", 1, args); + res = jit_emit_call ("unbind_n", comp.lisp_obj_type, 1, args); } break; case Bpophandler: @@ -548,12 +552,12 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, break; case Beq: POP2; - res = jit_emit_call ("Feq", 2, args); + res = jit_emit_call ("Feq", comp.lisp_obj_type, 2, args); PUSH (gcc_jit_lvalue_as_rvalue (res)); break; case Bmemq: POP1; - res = jit_emit_call ("Fmemq", 1, args); + res = jit_emit_call ("Fmemq", comp.lisp_obj_type, 1, args); PUSH (gcc_jit_lvalue_as_rvalue (res)); break; break; @@ -562,17 +566,17 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, break; case Bcar: POP1; - res = jit_emit_call ("Fcar", 1, args); + res = jit_emit_call ("Fcar", comp.lisp_obj_type, 1, args); PUSH (gcc_jit_lvalue_as_rvalue (res)); break; case Bcdr: POP1; - res = jit_emit_call ("Fcdr", 1, args); + res = jit_emit_call ("Fcdr", comp.lisp_obj_type, 1, args); PUSH (gcc_jit_lvalue_as_rvalue (res)); break; case Bcons: POP2; - res = jit_emit_call ("Fcons", 2, args); + res = jit_emit_call ("Fcons", comp.lisp_obj_type, 2, args); PUSH (gcc_jit_lvalue_as_rvalue (res)); break; @@ -591,12 +595,12 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, args[1] = gcc_jit_context_new_rvalue_from_ptr(comp.ctxt, comp.lisp_obj_type, Qnil); - res = jit_emit_call ("Fcons", 2, args); + res = jit_emit_call ("Fcons", comp.lisp_obj_type, 2, args); PUSH (gcc_jit_lvalue_as_rvalue (res)); for (int i = 0; i < op; ++i) { POP2; - res = jit_emit_call ("Fcons", 2, args); + res = jit_emit_call ("Fcons", comp.lisp_obj_type, 2, args); PUSH (gcc_jit_lvalue_as_rvalue (res)); } break; commit 1f2529df7d4663597d6ac72ac001def4cd049c1b Author: Andrea Corallo Date: Fri May 24 10:45:14 2019 +0200 add Bunbind diff --git a/src/comp.c b/src/comp.c index 315f74d967..e7a8b9b0e9 100644 --- a/src/comp.c +++ b/src/comp.c @@ -497,29 +497,30 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, PUSH (gcc_jit_lvalue_as_rvalue (res)); break; } + + case Bunbind6: + op = FETCH; + goto dounbind; + + case Bunbind7: + op = FETCH2; + goto dounbind; + case Bunbind: - printf("Bunbind\n"); - break; case Bunbind1: - printf("Bunbind1\n"); - break; case Bunbind2: - printf("Bunbind2\n"); - break; case Bunbind3: - printf("Bunbind3\n"); - break; case Bunbind4: - printf("Bunbind4\n"); - break; case Bunbind5: - printf("Bunbind5\n"); - break; - case Bunbind6: - printf("Bunbind6\n"); - break; - case Bunbind7: - printf("Bunbind7\n"); + op -= Bunbind; + dounbind: + { + args[0] = gcc_jit_context_new_rvalue_from_int(comp.ctxt, + comp.ptrdiff_type, + op); + + res = jit_emit_call ("unbind_n", 1, args); + } break; case Bpophandler: printf("Bpophandler\n"); commit 25127da57f5de6ca42c90206f1bb7de0efb41ea0 Author: Andrea Corallo Date: Fri May 24 10:28:21 2019 +0200 rename type diff --git a/src/comp.c b/src/comp.c index 2835a4ad69..315f74d967 100644 --- a/src/comp.c +++ b/src/comp.c @@ -297,7 +297,7 @@ jit_emit_Ffuncall (unsigned nargs, gcc_jit_rvalue **args) gcc_jit_lvalue *res = gcc_jit_function_new_local(comp.func, NULL, - comp.lisp_obj, + comp.lisp_obj_type, "res"); gcc_jit_block_add_assignment(comp.block, NULL, res, @@ -403,7 +403,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, varref: { args[0] = gcc_jit_context_new_rvalue_from_ptr(comp.ctxt, - comp.lisp_obj, + comp.lisp_obj_type, vectorp[op]); res = jit_emit_call ("Fsymbol_value", 1, args); PUSH (gcc_jit_lvalue_as_rvalue (res)); @@ -430,10 +430,10 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, POP1; args[1] = args[0]; args[0] = gcc_jit_context_new_rvalue_from_ptr(comp.ctxt, - comp.lisp_obj, + comp.lisp_obj_type, vectorp[op]); args[2] = gcc_jit_context_new_rvalue_from_ptr(comp.ctxt, - comp.lisp_obj, + comp.lisp_obj_type, Qnil); args[3] = gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.int_type, @@ -460,12 +460,10 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, op -= Bvarbind; varbind: { - POP1; - args[1] = args[0]; args[0] = gcc_jit_context_new_rvalue_from_ptr(comp.ctxt, - comp.lisp_obj, + comp.lisp_obj_type, vectorp[op]); - + pop (1, &stack, &args[1]); res = jit_emit_call ("specbind", 2, args); PUSH (gcc_jit_lvalue_as_rvalue (res)); break; @@ -590,7 +588,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, { POP1; args[1] = gcc_jit_context_new_rvalue_from_ptr(comp.ctxt, - comp.lisp_obj, + comp.lisp_obj_type, Qnil); res = jit_emit_call ("Fcons", 2, args); PUSH (gcc_jit_lvalue_as_rvalue (res)); @@ -943,7 +941,7 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, { gcc_jit_rvalue *c = gcc_jit_context_new_rvalue_from_ptr(comp.ctxt, - comp.lisp_obj, + comp.lisp_obj_type, vectorp[op]); PUSH (c); Fprint(vectorp[op], Qnil); @@ -1095,10 +1093,10 @@ init_comp (void) #if EMACS_INT_MAX <= LONG_MAX /* 32-bit builds without wide ints, 64-bit builds on Posix hosts. */ - comp.lisp_obj = gcc_jit_context_get_type(comp.ctxt, GCC_JIT_TYPE_VOID_PTR); + comp.lisp_obj_type = gcc_jit_context_get_type(comp.ctxt, GCC_JIT_TYPE_VOID_PTR); #else /* 64-bit builds on MS-Windows, 32-bit builds with wide ints. */ - comp.lisp_obj = gcc_jit_context_get_type(comp.ctxt, GCC_JIT_TYPE_LONG_LONG); + comp.lisp_obj_type = gcc_jit_context_get_type(comp.ctxt, GCC_JIT_TYPE_LONG_LONG); #endif comp.int_type = gcc_jit_context_get_type(comp.ctxt, GCC_JIT_TYPE_INT); @@ -1122,13 +1120,13 @@ init_comp (void) "nargs"), gcc_jit_context_new_param(comp.ctxt, NULL, - gcc_jit_type_get_pointer (comp.lisp_obj), + gcc_jit_type_get_pointer (comp.lisp_obj_type), "args") }; comp.Ffuncall = gcc_jit_context_new_function(comp.ctxt, NULL, GCC_JIT_FUNCTION_IMPORTED, - comp.lisp_obj, + comp.lisp_obj_type, "Ffuncall", 2, funcall_param, @@ -1138,7 +1136,7 @@ init_comp (void) gcc_jit_lvalue_get_address( gcc_jit_context_new_global (comp.ctxt, NULL, GCC_JIT_GLOBAL_IMPORTED, - comp.lisp_obj, + comp.lisp_obj_type, "scratch_call_area"), NULL); commit 54e18532e7e731ec556e4039d677592215a78ac3 Author: Andrea Corallo Date: Tue May 21 22:29:46 2019 +0200 add funcall diff --git a/src/comp.c b/src/comp.c index 5bc2c8fa4e..2835a4ad69 100644 --- a/src/comp.c +++ b/src/comp.c @@ -29,8 +29,14 @@ along with GNU Emacs. If not, see . */ #include "bytecode.h" #include "atimer.h" +#define COMP_DEBUG 0 + #define MAX_FUN_NAME 256 +/* Max number of args we are able to handle while emitting function calls. */ + +#define MAX_ARGS 16 + #define DISASS_FILE_NAME "emacs-asm.s" #define CHECK_STACK \ @@ -83,15 +89,22 @@ along with GNU Emacs. If not, see . */ typedef struct { gcc_jit_context *ctxt; - gcc_jit_type *lisp_obj; + gcc_jit_type *lisp_obj_type; gcc_jit_type *int_type; + gcc_jit_type *ptrdiff_type; gcc_jit_function *func; /* Current function being compiled */ + gcc_jit_function *Ffuncall; /* Current function being compiled */ + gcc_jit_rvalue *scratch; /* Will point to scratch_call_area */ gcc_jit_block *block; /* Current basic block */ Lisp_Object func_hash; /* f_name -> gcc_func */ } comp_t; static comp_t comp; +Lisp_Object scratch_call_area[MAX_ARGS]; + +FILE *logfile; + /* The result of one function compilation. */ typedef struct { @@ -99,6 +112,9 @@ typedef struct { short min_args, max_args; } comp_f_res_t; +INLINE static void pop (unsigned n, gcc_jit_rvalue ***stack_ref, + gcc_jit_rvalue *args[]); + static gcc_jit_function *jit_func_declare (const char *f_name, unsigned nargs, gcc_jit_rvalue **args, enum gcc_jit_function_kind kind, @@ -107,10 +123,26 @@ static gcc_jit_function *jit_func_declare (const char *f_name, unsigned nargs, void emacs_native_compile (const char *lisp_f_name, const char *c_f_name, Lisp_Object func, bool dump_asm); +/* Pop form the main evaluation stack and place the elements in args in reversed + order. */ + +INLINE static void +pop (unsigned n, gcc_jit_rvalue ***stack_ref, gcc_jit_rvalue *args[]) +{ + gcc_jit_rvalue **stack = *stack_ref; + + while (n--) + { + stack--; + args[n] = *stack; + } + + *stack_ref = stack; +} + static gcc_jit_function * jit_func_declare (const char *f_name, unsigned nargs, gcc_jit_rvalue **args, - enum gcc_jit_function_kind kind, - bool reusable) + enum gcc_jit_function_kind kind, bool reusable) { gcc_jit_param *param[4]; gcc_jit_type *type[4]; @@ -122,7 +154,7 @@ jit_func_declare (const char *f_name, unsigned nargs, gcc_jit_rvalue **args, type[i] = gcc_jit_rvalue_get_type (args[i]); else for (int i = 0; i < nargs; i++) - type[i] = comp.lisp_obj; + type[i] = comp.lisp_obj_type; switch (nargs) { case 4: @@ -163,7 +195,7 @@ jit_func_declare (const char *f_name, unsigned nargs, gcc_jit_rvalue **args, gcc_jit_function *func = gcc_jit_context_new_function(comp.ctxt, NULL, kind, - comp.lisp_obj, + comp.lisp_obj_type, f_name, nargs, param, @@ -207,7 +239,7 @@ jit_emit_call (const char *f_name, unsigned nargs, gcc_jit_rvalue **args) gcc_jit_lvalue *res = gcc_jit_function_new_local(comp.func, NULL, - comp.lisp_obj, + comp.lisp_obj_type, "res"); gcc_jit_block_add_assignment(comp.block, NULL, res, @@ -219,6 +251,64 @@ jit_emit_call (const char *f_name, unsigned nargs, gcc_jit_rvalue **args) return res; } +static gcc_jit_lvalue * +jit_emit_Ffuncall (unsigned nargs, gcc_jit_rvalue **args) +{ + + /* Here we set all the pointers into the scratch call area. */ + /* TODO: distinguish primitive for faster call convention. */ + + /* + Lisp_Object *p; + p = scratch_call_area; + + p[0] = 0x...; + . + . + . + p[n] = 0x...; + */ + + gcc_jit_lvalue *p = + gcc_jit_function_new_local(comp.func, + NULL, + gcc_jit_type_get_pointer (comp.lisp_obj_type), + "p"); + + gcc_jit_block_add_assignment(comp.block, NULL, + p, + comp.scratch); + + for (int i = 0; i < nargs; i++) { + gcc_jit_rvalue *idx = + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + gcc_jit_context_get_type(comp.ctxt, + GCC_JIT_TYPE_UNSIGNED_INT), + i); + gcc_jit_block_add_assignment (comp.block, NULL, + gcc_jit_context_new_array_access (comp.ctxt, + NULL, + gcc_jit_lvalue_as_rvalue(p), + idx), + args[i + 1]); + } + + args[1] = comp.scratch; + + gcc_jit_lvalue *res = gcc_jit_function_new_local(comp.func, + NULL, + comp.lisp_obj, + "res"); + gcc_jit_block_add_assignment(comp.block, NULL, + res, + gcc_jit_context_new_call(comp.ctxt, + NULL, + comp.Ffuncall, + 2, + args)); + return res; +} + static comp_f_res_t compile_f (const char *f_name, ptrdiff_t bytestr_length, unsigned char *bytestr_data, @@ -381,30 +471,34 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, break; } + case Bcall6: + op = FETCH; + goto docall; + + case Bcall7: + op = FETCH2; + goto docall; + case Bcall: - printf("Bcall\n"); - break; case Bcall1: - printf("Bcall1\n"); - break; case Bcall2: - printf("Bcall2\n"); - break; case Bcall3: - printf("Bcall3\n"); - break; case Bcall4: - printf("Bcall4\n"); - break; case Bcall5: - printf("Bcall5\n"); - break; - case Bcall6: - printf("Bcall6\n"); - break; - case Bcall7: - printf("Bcall7\n"); - break; + op -= Bcall; + docall: + { + ptrdiff_t nargs = op + 1; + + args[0] = gcc_jit_context_new_rvalue_from_int(comp.ctxt, + comp.ptrdiff_type, + nargs); + pop (nargs, &stack, &args[1]); + + res = jit_emit_Ffuncall (nargs, args); + PUSH (gcc_jit_lvalue_as_rvalue (res)); + break; + } case Bunbind: printf("Bunbind\n"); break; @@ -916,6 +1010,7 @@ emacs_native_compile (const char *lisp_f_name, const char *c_f_name, x->s.header.size = PVEC_SUBR << PSEUDOVECTOR_AREA_BITS; x->s.function.a0 = gcc_jit_result_get_code(comp_res.gcc_res, c_f_name); + eassert (x->s.function.a0); x->s.min_args = comp_res.min_args; x->s.max_args = comp_res.max_args; x->s.symbol_name = lisp_f_name; @@ -1007,15 +1102,61 @@ init_comp (void) #endif comp.int_type = gcc_jit_context_get_type(comp.ctxt, GCC_JIT_TYPE_INT); + + enum gcc_jit_types ptrdiff_t_gcc; + if (sizeof (ptrdiff_t) == sizeof (int)) + ptrdiff_t_gcc = GCC_JIT_TYPE_INT; + else if (sizeof (ptrdiff_t) == sizeof (long int)) + ptrdiff_t_gcc = GCC_JIT_TYPE_LONG; + else if (sizeof (ptrdiff_t) == sizeof (long long int)) + ptrdiff_t_gcc = GCC_JIT_TYPE_LONG_LONG; + else + eassert ("ptrdiff_t size not handled."); + + comp.ptrdiff_type = gcc_jit_context_get_type(comp.ctxt, ptrdiff_t_gcc); + + gcc_jit_param *funcall_param[2] = { + gcc_jit_context_new_param(comp.ctxt, + NULL, + comp.ptrdiff_type, + "nargs"), + gcc_jit_context_new_param(comp.ctxt, + NULL, + gcc_jit_type_get_pointer (comp.lisp_obj), + "args") }; + + comp.Ffuncall = + gcc_jit_context_new_function(comp.ctxt, NULL, + GCC_JIT_FUNCTION_IMPORTED, + comp.lisp_obj, + "Ffuncall", + 2, + funcall_param, + 0); + + comp.scratch = + gcc_jit_lvalue_get_address( + gcc_jit_context_new_global (comp.ctxt, NULL, + GCC_JIT_GLOBAL_IMPORTED, + comp.lisp_obj, + "scratch_call_area"), + NULL); + comp.func_hash = CALLN (Fmake_hash_table, QCtest, Qequal, QCweakness, Qt); - /* gcc_jit_context_set_bool_option(comp.ctxt, */ - /* GCC_JIT_BOOL_OPTION_DUMP_EVERYTHING, */ - /* 1); */ + if (COMP_DEBUG) { + logfile = fopen ("libjit.log", "w"); + gcc_jit_context_set_logfile (comp.ctxt, + logfile, + 0, 0); + gcc_jit_context_set_bool_option (comp.ctxt, + GCC_JIT_BOOL_OPTION_DUMP_EVERYTHING, + 1); + } - gcc_jit_context_set_bool_option(comp.ctxt, - GCC_JIT_BOOL_OPTION_KEEP_INTERMEDIATES, - 1); + gcc_jit_context_set_bool_option (comp.ctxt, + GCC_JIT_BOOL_OPTION_KEEP_INTERMEDIATES, + 1); } void @@ -1023,6 +1164,9 @@ release_comp (void) { if (comp.ctxt) gcc_jit_context_release(comp.ctxt); + + if (COMP_DEBUG) + fclose (logfile); } void diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 5847d5cf85..313f6906cd 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -76,6 +76,17 @@ (should (= comp-tests-var1 55))) +(ert-deftest comp-tests-ffuncall () + "Testing varset." + (defun comp-tests-ffuncall-callee-f (x y z) + (list x y z)) + (defun comp-tests-ffuncall-caller-f () + (comp-tests-ffuncall-callee-f 1 2 3)) + (byte-compile #'comp-tests-ffuncall-caller-f) + (native-compile #'comp-tests-ffuncall-caller-f) + + (should (equal (comp-tests-ffuncall-caller-f) '(1 2 3)))) + (ert-deftest comp-tests-gc () "Try to do some longer computation to let the gc kick in." (dotimes (_ 100000) commit 5238cd1e6a9b3c310743fdb4497f8f16d965367e Author: Andrea Corallo Date: Tue May 21 21:24:34 2019 +0200 add varbind support diff --git a/src/comp.c b/src/comp.c index 9713a6fd45..5bc2c8fa4e 100644 --- a/src/comp.c +++ b/src/comp.c @@ -353,30 +353,34 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length, } break; + case Bvarbind6: + op = FETCH; + goto varbind; + + case Bvarbind7: + op = FETCH2; + goto varbind; + case Bvarbind: - printf("Bvarbind\n"); - break; case Bvarbind1: - printf("Bvarbind1\n"); - break; case Bvarbind2: - printf("Bvarbind2\n"); - break; case Bvarbind3: - printf("Bvarbind3\n"); - break; case Bvarbind4: - printf("Bvarbind4\n"); - break; case Bvarbind5: - printf("Bvarbind5\n"); - break; - case Bvarbind6: - printf("Bvarbind6\n"); - break; - case Bvarbind7: - printf("Bvarbind7\n"); - break; + op -= Bvarbind; + varbind: + { + POP1; + args[1] = args[0]; + args[0] = gcc_jit_context_new_rvalue_from_ptr(comp.ctxt, + comp.lisp_obj, + vectorp[op]); + + res = jit_emit_call ("specbind", 2, args); + PUSH (gcc_jit_lvalue_as_rvalue (res)); + break; + } + case Bcall: printf("Bcall\n"); break; commit 01442a9ac9c6e6a652b628cf18b90a7e30bff845 Author: Andrea Corallo Date: Sat May 11 21:12:21 2019 +0200 Add native compiler comp.c diff --git a/src/Makefile.in b/src/Makefile.in index 4a66016e97..8e3712709e 100644 --- a/src/Makefile.in +++ b/src/Makefile.in @@ -416,7 +416,7 @@ base_obj = dispnew.o frame.o scroll.o xdisp.o menu.o $(XMENU_OBJ) window.o \ cmds.o casetab.o casefiddle.o indent.o search.o regex-emacs.o undo.o \ alloc.o pdumper.o data.o doc.o editfns.o callint.o \ eval.o floatfns.o fns.o font.o print.o lread.o $(MODULES_OBJ) \ - syntax.o $(UNEXEC_OBJ) bytecode.o \ + syntax.o $(UNEXEC_OBJ) bytecode.o comp.o \ process.o gnutls.o callproc.o \ region-cache.o sound.o timefns.o atimer.o \ doprnt.o intervals.o textprop.o composite.o xml.o lcms.o $(NOTIFY_OBJ) \ diff --git a/src/comp.c b/src/comp.c new file mode 100644 index 0000000000..9713a6fd45 --- /dev/null +++ b/src/comp.c @@ -0,0 +1,1032 @@ +/* Compile byte code produced by bytecomp.el into native code. + Copyright (C) 2019 Free Software Foundation, Inc. + +This file is part of GNU Emacs. + +GNU Emacs is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or (at +your option) any later version. + +GNU Emacs is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Emacs. If not, see . */ + +#include + +#ifdef HAVE_LIBGCCJIT + +#include +#include +#include + +#include "lisp.h" +#include "buffer.h" +#include "bytecode.h" +#include "atimer.h" + +#define MAX_FUN_NAME 256 + +#define DISASS_FILE_NAME "emacs-asm.s" + +#define CHECK_STACK \ + eassert (stack >= stack_base && stack < stack_over) + +#define PUSH(obj) \ + do { \ + CHECK_STACK; \ + *stack = obj; \ + stack++; \ + } while (0) + +#define POP1 \ + do { \ + stack--; \ + CHECK_STACK; \ + args[0] = *stack; \ + } while (0) + +#define POP2 \ + do { \ + stack--; \ + CHECK_STACK; \ + args[1] = *stack; \ + stack--; \ + args[0] = *stack; \ + } while (0) + +#define POP3 \ + do { \ + stack--; \ + CHECK_STACK; \ + args[2] = *stack; \ + stack--; \ + args[1] = *stack; \ + stack--; \ + args[0] = *stack; \ + } while (0) + +/* Fetch the next byte from the bytecode stream. */ + +#define FETCH (bytestr_data[pc++]) + +/* Fetch two bytes from the bytecode stream and make a 16-bit number + out of them. */ + +#define FETCH2 (op = FETCH, op + (FETCH << 8)) + +/* The compiler context */ + +typedef struct { + gcc_jit_context *ctxt; + gcc_jit_type *lisp_obj; + gcc_jit_type *int_type; + gcc_jit_function *func; /* Current function being compiled */ + gcc_jit_block *block; /* Current basic block */ + Lisp_Object func_hash; /* f_name -> gcc_func */ +} comp_t; + +static comp_t comp; + +/* The result of one function compilation. */ + +typedef struct { + gcc_jit_result *gcc_res; + short min_args, max_args; +} comp_f_res_t; + +static gcc_jit_function *jit_func_declare (const char *f_name, unsigned nargs, + gcc_jit_rvalue **args, + enum gcc_jit_function_kind kind, + bool reusable); + +void emacs_native_compile (const char *lisp_f_name, const char *c_f_name, + Lisp_Object func, bool dump_asm); + +static gcc_jit_function * +jit_func_declare (const char *f_name, unsigned nargs, gcc_jit_rvalue **args, + enum gcc_jit_function_kind kind, + bool reusable) +{ + gcc_jit_param *param[4]; + gcc_jit_type *type[4]; + + /* If args are passed types are extracted from that otherwise assume params */ + /* are all lisp objs. */ + if (args) + for (int i = 0; i < nargs; i++) + type[i] = gcc_jit_rvalue_get_type (args[i]); + else + for (int i = 0; i < nargs; i++) + type[i] = comp.lisp_obj; + + switch (nargs) { + case 4: + param[3] = gcc_jit_context_new_param(comp.ctxt, + NULL, + type[3], + "c"); + /* Fall through */ + FALLTHROUGH; + case 3: + param[2] = gcc_jit_context_new_param(comp.ctxt, + NULL, + type[2], + "c"); + /* Fall through */ + FALLTHROUGH; + case 2: + param[1] = gcc_jit_context_new_param(comp.ctxt, + NULL, + type[1], + "b"); + /* Fall through */ + FALLTHROUGH; + case 1: + param[0] = gcc_jit_context_new_param(comp.ctxt, + NULL, + type[0], + "a"); + /* Fall through */ + FALLTHROUGH; + case 0: + break; + default: + /* Argnum not supported */ + eassert (0); + } + + gcc_jit_function *func = + gcc_jit_context_new_function(comp.ctxt, NULL, + kind, + comp.lisp_obj, + f_name, + nargs, + param, + 0); + + if (reusable) + { + Lisp_Object value; + Lisp_Object key = make_string (f_name, strlen (f_name)); + value = make_pointer_integer (XPL (func)); + + EMACS_UINT hash = 0; + struct Lisp_Hash_Table *ht = XHASH_TABLE (comp.func_hash); + ptrdiff_t i = hash_lookup (ht, key, &hash); + /* Don't want to declare the same function two times */ + eassert (i == -1); + hash_put (ht, key, value, hash); + } + + return func; +} + +static gcc_jit_lvalue * +jit_emit_call (const char *f_name, unsigned nargs, gcc_jit_rvalue **args) +{ + Lisp_Object key = make_string (f_name, strlen (f_name)); + EMACS_UINT hash = 0; + struct Lisp_Hash_Table *ht = XHASH_TABLE (comp.func_hash); + ptrdiff_t i = hash_lookup (ht, key, &hash); + + if (i == -1) + { + jit_func_declare(f_name, nargs, args, GCC_JIT_FUNCTION_IMPORTED, + true); + i = hash_lookup (ht, key, &hash); + eassert (i != -1); + } + + Lisp_Object value = HASH_VALUE (ht, hash_lookup (ht, key, &hash)); + gcc_jit_function *func = (gcc_jit_function *) XFIXNUMPTR (value); + + gcc_jit_lvalue *res = gcc_jit_function_new_local(comp.func, + NULL, + comp.lisp_obj, + "res"); + gcc_jit_block_add_assignment(comp.block, NULL, + res, + gcc_jit_context_new_call(comp.ctxt, + NULL, + func, + nargs, + args)); + return res; +} + +static comp_f_res_t +compile_f (const char *f_name, ptrdiff_t bytestr_length, + unsigned char *bytestr_data, + EMACS_INT stack_depth, Lisp_Object *vectorp, + ptrdiff_t vector_size, Lisp_Object args_template) +{ + gcc_jit_lvalue *res; + comp_f_res_t comp_res = { NULL, 0, 0 }; + ptrdiff_t pc = 0; + gcc_jit_rvalue *args[4]; + unsigned op; + + /* This is the stack we use to flat the bytecode written for push and pop + Emacs VM.*/ + gcc_jit_rvalue **stack_base, **stack, **stack_over; + stack_base = stack = + (gcc_jit_rvalue **) xmalloc (stack_depth * sizeof (gcc_jit_rvalue *)); + stack_over = stack_base + stack_depth; + + if (FIXNUMP (args_template)) + { + ptrdiff_t at = XFIXNUM (args_template); + bool rest = (at & 128) != 0; + int mandatory = at & 127; + ptrdiff_t nonrest = at >> 8; + + comp_res.min_args = mandatory; + + eassert (!rest); + + if (!rest && nonrest < SUBR_MAX_ARGS) + comp_res.max_args = nonrest; + } + else if (CONSP (args_template)) + /* FIXME */ + comp_res.min_args = comp_res.max_args = XFIXNUM (Flength (args_template)); + + else + eassert (SYMBOLP (args_template) && args_template == Qnil); + + + /* Current function being compiled. Return a lips obj. */ + comp.func = jit_func_declare (f_name, comp_res.max_args, NULL, + GCC_JIT_FUNCTION_EXPORTED, false); + + for (ptrdiff_t i = 0; i < comp_res.max_args; ++i) + PUSH (gcc_jit_param_as_rvalue (gcc_jit_function_get_param (comp.func, i))); + + comp.block = gcc_jit_function_new_block(comp.func, "foo_blk"); + + while (pc < bytestr_length) + { + op = FETCH; + printf ("pc %td\t%ud\n", pc, op); + switch (op) + { + case Bstack_ref1: + case Bstack_ref2: + case Bstack_ref3: + case Bstack_ref4: + case Bstack_ref5: + { + PUSH (stack_base[(stack - stack_base) - (op - Bstack_ref) - 1]); + break; + } + case Bstack_ref6: + { + PUSH (stack_base[(stack - stack_base) - FETCH - 1]); + break; + } + case Bstack_ref7: + { + PUSH (stack_base[(stack - stack_base) - FETCH2 - 1]); + break; + } + + case Bvarref7: + op = FETCH2; + goto varref; + + case Bvarref: + case Bvarref1: + case Bvarref2: + case Bvarref3: + case Bvarref4: + case Bvarref5: + op -= Bvarref; + goto varref; + + case Bvarref6: + op = FETCH; + varref: + { + args[0] = gcc_jit_context_new_rvalue_from_ptr(comp.ctxt, + comp.lisp_obj, + vectorp[op]); + res = jit_emit_call ("Fsymbol_value", 1, args); + PUSH (gcc_jit_lvalue_as_rvalue (res)); + break; + } + + case Bvarset: + case Bvarset1: + case Bvarset2: + case Bvarset3: + case Bvarset4: + case Bvarset5: + op -= Bvarset; + goto varset; + + case Bvarset7: + op = FETCH2; + goto varset; + + case Bvarset6: + op = FETCH; + varset: + { + POP1; + args[1] = args[0]; + args[0] = gcc_jit_context_new_rvalue_from_ptr(comp.ctxt, + comp.lisp_obj, + vectorp[op]); + args[2] = gcc_jit_context_new_rvalue_from_ptr(comp.ctxt, + comp.lisp_obj, + Qnil); + args[3] = gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.int_type, + SET_INTERNAL_SET); + res = jit_emit_call ("set_internal", 4, args); + PUSH (gcc_jit_lvalue_as_rvalue (res)); + } + break; + + case Bvarbind: + printf("Bvarbind\n"); + break; + case Bvarbind1: + printf("Bvarbind1\n"); + break; + case Bvarbind2: + printf("Bvarbind2\n"); + break; + case Bvarbind3: + printf("Bvarbind3\n"); + break; + case Bvarbind4: + printf("Bvarbind4\n"); + break; + case Bvarbind5: + printf("Bvarbind5\n"); + break; + case Bvarbind6: + printf("Bvarbind6\n"); + break; + case Bvarbind7: + printf("Bvarbind7\n"); + break; + case Bcall: + printf("Bcall\n"); + break; + case Bcall1: + printf("Bcall1\n"); + break; + case Bcall2: + printf("Bcall2\n"); + break; + case Bcall3: + printf("Bcall3\n"); + break; + case Bcall4: + printf("Bcall4\n"); + break; + case Bcall5: + printf("Bcall5\n"); + break; + case Bcall6: + printf("Bcall6\n"); + break; + case Bcall7: + printf("Bcall7\n"); + break; + case Bunbind: + printf("Bunbind\n"); + break; + case Bunbind1: + printf("Bunbind1\n"); + break; + case Bunbind2: + printf("Bunbind2\n"); + break; + case Bunbind3: + printf("Bunbind3\n"); + break; + case Bunbind4: + printf("Bunbind4\n"); + break; + case Bunbind5: + printf("Bunbind5\n"); + break; + case Bunbind6: + printf("Bunbind6\n"); + break; + case Bunbind7: + printf("Bunbind7\n"); + break; + case Bpophandler: + printf("Bpophandler\n"); + break; + case Bpushconditioncase: + printf("Bpushconditioncase\n"); + break; + case Bpushcatch: + printf("Bpushcatch\n"); + break; + case Bnth: + printf("Bnth\n"); + break; + case Bsymbolp: + printf("Bsymbolp\n"); + break; + case Bconsp: + printf("Bconsp\n"); + break; + case Bstringp: + printf("Bstringp\n"); + break; + case Blistp: + printf("Blistp\n"); + break; + case Beq: + POP2; + res = jit_emit_call ("Feq", 2, args); + PUSH (gcc_jit_lvalue_as_rvalue (res)); + break; + case Bmemq: + POP1; + res = jit_emit_call ("Fmemq", 1, args); + PUSH (gcc_jit_lvalue_as_rvalue (res)); + break; + break; + case Bnot: + printf("Bnot\n"); + break; + case Bcar: + POP1; + res = jit_emit_call ("Fcar", 1, args); + PUSH (gcc_jit_lvalue_as_rvalue (res)); + break; + case Bcdr: + POP1; + res = jit_emit_call ("Fcdr", 1, args); + PUSH (gcc_jit_lvalue_as_rvalue (res)); + break; + case Bcons: + POP2; + res = jit_emit_call ("Fcons", 2, args); + PUSH (gcc_jit_lvalue_as_rvalue (res)); + break; + + case BlistN: + op = FETCH; + goto make_list; + + case Blist1: + case Blist2: + case Blist3: + case Blist4: + op = op - Blist1; + make_list: + { + POP1; + args[1] = gcc_jit_context_new_rvalue_from_ptr(comp.ctxt, + comp.lisp_obj, + Qnil); + res = jit_emit_call ("Fcons", 2, args); + PUSH (gcc_jit_lvalue_as_rvalue (res)); + for (int i = 0; i < op; ++i) + { + POP2; + res = jit_emit_call ("Fcons", 2, args); + PUSH (gcc_jit_lvalue_as_rvalue (res)); + } + break; + } + + case Blength: + printf("Blength\n"); + break; + case Baref: + printf("Baref\n"); + break; + case Baset: + printf("Baset\n"); + break; + case Bsymbol_value: + printf("Bsymbol_value\n"); + break; + case Bsymbol_function: + printf("Bsymbol_function\n"); + break; + case Bset: + printf("Bset\n"); + break; + case Bfset: + printf("Bfset\n"); + break; + case Bget: + printf("Bget\n"); + break; + case Bsubstring: + printf("Bsubstring\n"); + break; + case Bconcat2: + printf("Bconcat2\n"); + break; + case Bconcat3: + printf("Bconcat3\n"); + break; + case Bconcat4: + printf("Bconcat4\n"); + break; + case Bsub1: + printf("Bsub1\n"); + break; + case Badd1: + printf("Badd1\n"); + break; + case Beqlsign: + printf("Beqlsign\n"); + break; + case Bgtr: + printf("Bgtr\n"); + break; + case Blss: + printf("Blss\n"); + break; + case Bleq: + printf("Bleq\n"); + break; + case Bgeq: + printf("Bgeq\n"); + break; + case Bdiff: + printf("Bdiff\n"); + break; + case Bnegate: + printf("Bnegate\n"); + break; + case Bplus: + printf("Bplus\n"); + break; + case Bmax: + printf("Bmax\n"); + break; + case Bmin: + printf("Bmin\n"); + break; + case Bmult: + printf("Bmult\n"); + break; + case Bpoint: + printf("Bpoint\n"); + break; + case Bsave_current_buffer: + printf("Bsave_current_buffer\n"); + break; + case Bgoto_char: + printf("Bgoto_char\n"); + break; + case Binsert: + printf("Binsert\n"); + break; + case Bpoint_max: + printf("Bpoint_max\n"); + break; + case Bpoint_min: + printf("Bpoint_min\n"); + break; + case Bchar_after: + printf("Bchar_after\n"); + break; + case Bfollowing_char: + printf("Bfollowing_char\n"); + break; + case Bpreceding_char: + printf("Bpreceding_char\n"); + break; + case Bcurrent_column: + printf("Bcurrent_column\n"); + break; + case Bindent_to: + printf("Bindent_to\n"); + break; + case Beolp: + printf("Beolp\n"); + break; + case Beobp: + printf("Beobp\n"); + break; + case Bbolp: + printf("Bbolp\n"); + break; + case Bbobp: + printf("Bbobp\n"); + break; + case Bcurrent_buffer: + printf("Bcurrent_buffer\n"); + break; + case Bset_buffer: + printf("Bset_buffer\n"); + break; + case Bsave_current_buffer_1: + printf("Bsave_current_buffer_1\n"); + break; + case Binteractive_p: + printf("Binteractive_p\n"); + break; + case Bforward_char: + printf("Bforward_char\n"); + break; + case Bforward_word: + printf("Bforward_word\n"); + break; + case Bskip_chars_forward: + printf("Bskip_chars_forward\n"); + break; + case Bskip_chars_backward: + printf("Bskip_chars_backward\n"); + break; + case Bforward_line: + printf("Bforward_line\n"); + break; + case Bchar_syntax: + printf("Bchar_syntax\n"); + break; + case Bbuffer_substring: + printf("Bbuffer_substring\n"); + break; + case Bdelete_region: + printf("Bdelete_region\n"); + break; + case Bnarrow_to_region: + printf("Bnarrow_to_region\n"); + break; + case Bwiden: + printf("Bwiden\n"); + break; + case Bend_of_line: + printf("Bend_of_line\n"); + break; + case Bconstant2: + printf("Bconstant2\n"); + goto do_constant; + break; + case Bgoto: + printf("Bgoto\n"); + break; + case Bgotoifnil: + printf("Bgotoifnil\n"); + break; + case Bgotoifnonnil: + printf("Bgotoifnonnil\n"); + break; + case Bgotoifnilelsepop: + printf("Bgotoifnilelsepop\n"); + break; + case Bgotoifnonnilelsepop: + printf("Bgotoifnonnilelsepop\n"); + break; + case Breturn: + printf("Breturn\n"); + break; + case Bdiscard: + printf("Bdiscard\n"); + break; + case Bdup: + printf("Bdup\n"); + break; + case Bsave_excursion: + printf("Bsave_excursion\n"); + break; + case Bsave_window_excursion: + printf("Bsave_window_excursion\n"); + break; + case Bsave_restriction: + printf("Bsave_restriction\n"); + break; + case Bcatch: + printf("Bcatch\n"); + break; + case Bunwind_protect: + printf("Bunwind_protect\n"); + break; + case Bcondition_case: + printf("Bcondition_case\n"); + break; + case Btemp_output_buffer_setup: + printf("Btemp_output_buffer_setup\n"); + break; + case Btemp_output_buffer_show: + printf("Btemp_output_buffer_show\n"); + break; + case Bunbind_all: + printf("Bunbind_all\n"); + break; + case Bset_marker: + printf("Bset_marker\n"); + break; + case Bmatch_beginning: + printf("Bmatch_beginning\n"); + break; + case Bmatch_end: + printf("Bmatch_end\n"); + break; + case Bupcase: + printf("Bupcase\n"); + break; + case Bdowncase: + printf("Bdowncase\n"); + break; + case Bstringeqlsign: + printf("Bstringeqlsign\n"); + break; + case Bstringlss: + printf("Bstringlss\n"); + break; + case Bequal: + printf("Bequal\n"); + break; + case Bnthcdr: + printf("Bnthcdr\n"); + break; + case Belt: + printf("Belt\n"); + break; + case Bmember: + printf("Bmember\n"); + break; + case Bassq: + printf("Bassq\n"); + break; + case Bnreverse: + printf("Bnreverse\n"); + break; + case Bsetcar: + printf("Bsetcar\n"); + break; + case Bsetcdr: + printf("Bsetcdr\n"); + break; + case Bcar_safe: + printf("Bcar_safe\n"); + break; + case Bcdr_safe: + printf("Bcdr_safe\n"); + break; + case Bnconc: + printf("Bnconc\n"); + break; + case Bquo: + printf("Bquo\n"); + break; + case Brem: + printf("Brem\n"); + break; + case Bnumberp: + printf("Bnumberp\n"); + break; + case Bintegerp: + printf("Bintegerp\n"); + break; + case BRgoto: + printf("BRgoto\n"); + break; + case BRgotoifnil: + printf("BRgotoifnil\n"); + break; + case BRgotoifnonnil: + printf("BRgotoifnonnil\n"); + break; + case BRgotoifnilelsepop: + printf("BRgotoifnilelsepop\n"); + break; + case BRgotoifnonnilelsepop: + printf("BRgotoifnonnilelsepop\n"); + break; + case BconcatN: + printf("BconcatN\n"); + break; + case BinsertN: + printf("BinsertN\n"); + break; + case Bstack_set: + printf("Bstack_set\n"); + break; + case Bstack_set2: + printf("Bstack_set2\n"); + break; + case BdiscardN: + printf("BdiscardN\n"); + break; + case Bswitch: + printf("Bswitch\n"); + /* The cases of Bswitch that we handle (which in theory is + all of them) are done in Bconstant, below. This is done + due to a design issue with Bswitch -- it should have + taken a constant pool index inline, but instead looks for + a constant on the stack. */ + goto fail; + break; + default: + case Bconstant: + printf("Bconstant "); + { + if (op < Bconstant || op > Bconstant + vector_size) + goto fail; + + op -= Bconstant; + do_constant: + + /* See the Bswitch case for commentary. */ + if (pc >= bytestr_length || bytestr_data[pc] != Bswitch) + { + gcc_jit_rvalue *c = + gcc_jit_context_new_rvalue_from_ptr(comp.ctxt, + comp.lisp_obj, + vectorp[op]); + PUSH (c); + Fprint(vectorp[op], Qnil); + break; + } + + /* We're compiling Bswitch instead. */ + ++pc; + break; + } + } + } + + stack--; + gcc_jit_block_end_with_return(comp.block, + NULL, + *stack); + comp_res.gcc_res = gcc_jit_context_compile(comp.ctxt); + + goto exit; + + fail: + error ("Something went wrong"); + + exit: + xfree (stack_base); + return comp_res; +} + +void +emacs_native_compile (const char *lisp_f_name, const char *c_f_name, + Lisp_Object func, bool dump_asm) +{ + Lisp_Object bytestr = AREF (func, COMPILED_BYTECODE); + CHECK_STRING (bytestr); + + if (STRING_MULTIBYTE (bytestr)) + /* BYTESTR must have been produced by Emacs 20.2 or the earlier + because they produced a raw 8-bit string for byte-code and now + such a byte-code string is loaded as multibyte while raw 8-bit + characters converted to multibyte form. Thus, now we must + convert them back to the originally intended unibyte form. */ + bytestr = Fstring_as_unibyte (bytestr); + + ptrdiff_t bytestr_length = SBYTES (bytestr); + + Lisp_Object vector = AREF (func, COMPILED_CONSTANTS); + CHECK_VECTOR (vector); + Lisp_Object *vectorp = XVECTOR (vector)->contents; + + Lisp_Object maxdepth = AREF (func, COMPILED_STACK_DEPTH); + CHECK_FIXNAT (maxdepth); + + /* Gcc doesn't like being interrupted. */ + sigset_t oldset; + block_atimers (&oldset); + + comp_f_res_t comp_res = compile_f (c_f_name, bytestr_length, SDATA (bytestr), + XFIXNAT (maxdepth) + 1, + vectorp, ASIZE (vector), + AREF (func, COMPILED_ARGLIST)); + + union Aligned_Lisp_Subr *x = xmalloc (sizeof (union Aligned_Lisp_Subr)); + + x->s.header.size = PVEC_SUBR << PSEUDOVECTOR_AREA_BITS; + x->s.function.a0 = gcc_jit_result_get_code(comp_res.gcc_res, c_f_name); + x->s.min_args = comp_res.min_args; + x->s.max_args = comp_res.max_args; + x->s.symbol_name = lisp_f_name; + defsubr(x); + + if (dump_asm) + { + gcc_jit_context_compile_to_file(comp.ctxt, + GCC_JIT_OUTPUT_KIND_ASSEMBLER, + DISASS_FILE_NAME); + } + unblock_atimers (&oldset); +} + +DEFUN ("native-compile", Fnative_compile, Snative_compile, + 1, 2, 0, + doc: /* Compile as native code function FUNC and load it. */) /* FIXME doc */ + (Lisp_Object func, Lisp_Object disassemble) +{ + static char c_f_name[MAX_FUN_NAME]; + char *lisp_f_name; + + if (!SYMBOLP (func)) + error ("Not a symbol."); + + lisp_f_name = (char *) SDATA (SYMBOL_NAME (func)); + + int res = snprintf (c_f_name, MAX_FUN_NAME, "Fnative_comp_%s", lisp_f_name); + + if (res >= MAX_FUN_NAME) + error ("Function name too long"); + + /* FIXME how many other characters are not allowed in C? + This will introduce name clashs too. */ + for (int i; i < strlen(c_f_name); i++) + if (c_f_name[i] == '-') + c_f_name[i] = '_'; + + func = indirect_function (func); + if (!COMPILEDP (func)) + error ("Not a byte-compiled function"); + + emacs_native_compile (lisp_f_name, c_f_name, func, disassemble != Qnil); + + if (disassemble) + { + FILE *fd; + Lisp_Object str; + + if ((fd = fopen (DISASS_FILE_NAME, "r"))) + { + fseek (fd , 0L, SEEK_END); + long int size = ftell (fd); + fseek (fd , 0L, SEEK_SET); + char *buffer = xmalloc (size + 1); + ptrdiff_t nread = fread (buffer, 1, size, fd); + if (nread > 0) + { + size = nread; + buffer[size] = '\0'; + str = make_string (buffer, size); + fclose (fd); + } + else + str = empty_unibyte_string; + xfree (buffer); + return str; + } + else + { + error ("disassemble file could not be found"); + } + } + + return Qnil; +} + +void +init_comp (void) +{ + comp.ctxt = gcc_jit_context_acquire(); + +#if EMACS_INT_MAX <= LONG_MAX + /* 32-bit builds without wide ints, 64-bit builds on Posix hosts. */ + comp.lisp_obj = gcc_jit_context_get_type(comp.ctxt, GCC_JIT_TYPE_VOID_PTR); +#else + /* 64-bit builds on MS-Windows, 32-bit builds with wide ints. */ + comp.lisp_obj = gcc_jit_context_get_type(comp.ctxt, GCC_JIT_TYPE_LONG_LONG); +#endif + + comp.int_type = gcc_jit_context_get_type(comp.ctxt, GCC_JIT_TYPE_INT); + comp.func_hash = CALLN (Fmake_hash_table, QCtest, Qequal, QCweakness, Qt); + + /* gcc_jit_context_set_bool_option(comp.ctxt, */ + /* GCC_JIT_BOOL_OPTION_DUMP_EVERYTHING, */ + /* 1); */ + + gcc_jit_context_set_bool_option(comp.ctxt, + GCC_JIT_BOOL_OPTION_KEEP_INTERMEDIATES, + 1); +} + +void +release_comp (void) +{ + if (comp.ctxt) + gcc_jit_context_release(comp.ctxt); +} + +void +syms_of_comp (void) +{ + defsubr (&Snative_compile); + comp.func_hash = Qnil; + staticpro (&comp.func_hash); +} + +#endif /* HAVE_LIBJIT */ diff --git a/src/emacs.c b/src/emacs.c index 81703b4660..db6d54dff4 100644 --- a/src/emacs.c +++ b/src/emacs.c @@ -1598,6 +1598,11 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem init_json (); #endif +#ifdef HAVE_LIBGCCJIT + if (!initialized) + syms_of_comp (); +#endif + no_loadup = argmatch (argv, argc, "-nl", "--no-loadup", 6, NULL, &skip_args); @@ -1773,6 +1778,12 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem xputenv ("LANG=C"); #endif + /* This is here because init_buffer can already call Lisp. */ +#ifdef HAVE_LIBGCCJIT + if (initialized) + init_comp(); +#endif + /* Init buffer storage and default directory of main buffer. */ init_buffer (); @@ -2389,6 +2400,10 @@ all of which are called before Emacs is actually killed. */ unlink (SSDATA (listfile)); } +#ifdef HAVE_LIBGCCJIT + release_comp(); +#endif + if (FIXNUMP (arg)) exit_code = (XFIXNUM (arg) < 0 ? XFIXNUM (arg) | INT_MIN diff --git a/src/lisp.h b/src/lisp.h index 04e70f592f..5a563069df 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -4743,6 +4743,12 @@ extern bool profiler_memory_running; extern void malloc_probe (size_t); extern void syms_of_profiler (void); +/* Defined in comp.c. */ +#ifdef HAVE_LIBGCCJIT +extern void init_comp (void); +extern void release_comp (void); +extern void syms_of_comp (void); +#endif /* HAVE_LIBGCCJIT */ #ifdef DOS_NT /* Defined in msdos.c, w32.c. */ diff --git a/src/lread.c b/src/lread.c index 290b3d3d64..bedb3d57cb 100644 --- a/src/lread.c +++ b/src/lread.c @@ -4174,13 +4174,16 @@ intern_c_string_1 (const char *str, ptrdiff_t len) { Lisp_Object obarray = check_obarray (Vobarray); Lisp_Object tem = oblookup (obarray, str, len, len); + Lisp_Object string; if (!SYMBOLP (tem)) { - /* Creating a non-pure string from a string literal not implemented yet. - We could just use make_string here and live with the extra copy. */ - eassert (!NILP (Vpurify_flag)); - tem = intern_driver (make_pure_c_string (str, len), obarray, tem); + if NILP (Vpurify_flag) + string = make_string (str, len); + else + string = make_pure_c_string (str, len); + + tem = intern_driver (string, obarray, tem); } return tem; } diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el new file mode 100644 index 0000000000..5847d5cf85 --- /dev/null +++ b/test/src/comp-tests.el @@ -0,0 +1,86 @@ +;;; comp-tests.el --- unit tests for src/comp.c -*- lexical-binding: t; -*- + +;; Copyright (C) 2019 Free Software Foundation, Inc. + +;; Author: Andrea Corallo + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;; Unit tests for src/comp.c. + +;;; Code: + +(require 'ert) + +(setq garbage-collection-messages t) + +(defvar comp-tests-var1 3) + +(ert-deftest comp-tests-varref () + "Testing cons car cdr." + (defun comp-tests-varref-f () + comp-tests-var1) + + (byte-compile #'comp-tests-varref-f) + (native-compile #'comp-tests-varref-f) + + (should (= (comp-tests-varref-f) 3))) + +(ert-deftest comp-tests-list () + "Testing cons car cdr." + (defun comp-tests-list-f () + (list 1 2 3)) + + (byte-compile #'comp-tests-list-f) + (native-compile #'comp-tests-list-f) + + (should (equal (comp-tests-list-f) '(1 2 3)))) + +(ert-deftest comp-tests-cons-car-cdr () + "Testing cons car cdr." + (defun comp-tests-cons-car-f () + (car (cons 1 2))) + (byte-compile #'comp-tests-cons-car-f) + (native-compile #'comp-tests-cons-car-f) + + (defun comp-tests-cons-cdr-f (x) + (cdr (cons 'foo x))) + (byte-compile #'comp-tests-cons-cdr-f) + (native-compile #'comp-tests-cons-cdr-f) + + (should (= (comp-tests-cons-car-f) 1)) + (should (= (comp-tests-cons-cdr-f 3) 3))) + +(ert-deftest comp-tests-varset () + "Testing varset." + (defun comp-tests-varset-f () + (setq comp-tests-var1 55)) + (byte-compile #'comp-tests-varset-f) + (native-compile #'comp-tests-varset-f) + (comp-tests-varset-f) + + (should (= comp-tests-var1 55))) + +(ert-deftest comp-tests-gc () + "Try to do some longer computation to let the gc kick in." + (dotimes (_ 100000) + (comp-tests-cons-cdr-f 3)) + + (should (= (comp-tests-cons-cdr-f 3) 3))) + +;;; comp-tests.el ends here commit 64dfd59fd69d3f46e9a54ad2c88838e2bd32aac8 Author: Andrea Corallo Date: Tue May 21 20:57:22 2019 +0200 Make block_atimers unblock_atimers extern diff --git a/src/atimer.c b/src/atimer.c index a7daf9dcf5..4b0cab1453 100644 --- a/src/atimer.c +++ b/src/atimer.c @@ -65,22 +65,6 @@ enum { timerfd = -1 }; # endif #endif -/* Block/unblock SIGALRM. */ - -static void -block_atimers (sigset_t *oldset) -{ - sigset_t blocked; - sigemptyset (&blocked); - sigaddset (&blocked, SIGALRM); - sigaddset (&blocked, SIGINT); - pthread_sigmask (SIG_BLOCK, &blocked, oldset); -} -static void -unblock_atimers (sigset_t const *oldset) -{ - pthread_sigmask (SIG_SETMASK, oldset, 0); -} /* Function prototypes. */ @@ -165,6 +149,23 @@ start_atimer (enum atimer_type type, struct timespec timestamp, return t; } +/* Block/unblock SIGALRM. */ + +void +block_atimers (sigset_t *oldset) +{ + sigset_t blocked; + sigemptyset (&blocked); + sigaddset (&blocked, SIGALRM); + sigaddset (&blocked, SIGINT); + pthread_sigmask (SIG_BLOCK, &blocked, oldset); +} + +void +unblock_atimers (sigset_t const *oldset) +{ + pthread_sigmask (SIG_SETMASK, oldset, 0); +} /* Cancel and free atimer TIMER. */ diff --git a/src/atimer.h b/src/atimer.h index 660d77c939..58209168af 100644 --- a/src/atimer.h +++ b/src/atimer.h @@ -71,6 +71,8 @@ struct atimer struct atimer *start_atimer (enum atimer_type, struct timespec, atimer_callback, void *); +void block_atimers (sigset_t *); +void unblock_atimers (sigset_t const *); void cancel_atimer (struct atimer *); void do_pending_atimers (void); void init_atimer (void); commit 71d61b05d465a87d4e960704fc9e2e5cfef53077 Author: Tom Tromey Date: Wed Jan 10 16:27:39 2018 -0700 Create bytecode.h * src/bytecode.h: New file. * src/bytecode.c: Move bytecode definitions to bytecode.h. diff --git a/src/bytecode.c b/src/bytecode.c index 9e75c9012e..e11704fd8b 100644 --- a/src/bytecode.c +++ b/src/bytecode.c @@ -27,6 +27,7 @@ along with GNU Emacs. If not, see . */ #include "ptr-bounds.h" #include "syntax.h" #include "window.h" +#include "bytecode.h" /* Work around GCC bug 54561. */ #if GNUC_PREREQ (4, 3, 0) @@ -77,212 +78,6 @@ along with GNU Emacs. If not, see . */ #endif /* BYTE_CODE_METER */ -/* Byte codes: */ - -#define BYTE_CODES \ -DEFINE (Bstack_ref, 0) /* Actually, Bstack_ref+0 is not implemented: use dup. */ \ -DEFINE (Bstack_ref1, 1) \ -DEFINE (Bstack_ref2, 2) \ -DEFINE (Bstack_ref3, 3) \ -DEFINE (Bstack_ref4, 4) \ -DEFINE (Bstack_ref5, 5) \ -DEFINE (Bstack_ref6, 6) \ -DEFINE (Bstack_ref7, 7) \ -DEFINE (Bvarref, 010) \ -DEFINE (Bvarref1, 011) \ -DEFINE (Bvarref2, 012) \ -DEFINE (Bvarref3, 013) \ -DEFINE (Bvarref4, 014) \ -DEFINE (Bvarref5, 015) \ -DEFINE (Bvarref6, 016) \ -DEFINE (Bvarref7, 017) \ -DEFINE (Bvarset, 020) \ -DEFINE (Bvarset1, 021) \ -DEFINE (Bvarset2, 022) \ -DEFINE (Bvarset3, 023) \ -DEFINE (Bvarset4, 024) \ -DEFINE (Bvarset5, 025) \ -DEFINE (Bvarset6, 026) \ -DEFINE (Bvarset7, 027) \ -DEFINE (Bvarbind, 030) \ -DEFINE (Bvarbind1, 031) \ -DEFINE (Bvarbind2, 032) \ -DEFINE (Bvarbind3, 033) \ -DEFINE (Bvarbind4, 034) \ -DEFINE (Bvarbind5, 035) \ -DEFINE (Bvarbind6, 036) \ -DEFINE (Bvarbind7, 037) \ -DEFINE (Bcall, 040) \ -DEFINE (Bcall1, 041) \ -DEFINE (Bcall2, 042) \ -DEFINE (Bcall3, 043) \ -DEFINE (Bcall4, 044) \ -DEFINE (Bcall5, 045) \ -DEFINE (Bcall6, 046) \ -DEFINE (Bcall7, 047) \ -DEFINE (Bunbind, 050) \ -DEFINE (Bunbind1, 051) \ -DEFINE (Bunbind2, 052) \ -DEFINE (Bunbind3, 053) \ -DEFINE (Bunbind4, 054) \ -DEFINE (Bunbind5, 055) \ -DEFINE (Bunbind6, 056) \ -DEFINE (Bunbind7, 057) \ - \ -DEFINE (Bpophandler, 060) \ -DEFINE (Bpushconditioncase, 061) \ -DEFINE (Bpushcatch, 062) \ - \ -DEFINE (Bnth, 070) \ -DEFINE (Bsymbolp, 071) \ -DEFINE (Bconsp, 072) \ -DEFINE (Bstringp, 073) \ -DEFINE (Blistp, 074) \ -DEFINE (Beq, 075) \ -DEFINE (Bmemq, 076) \ -DEFINE (Bnot, 077) \ -DEFINE (Bcar, 0100) \ -DEFINE (Bcdr, 0101) \ -DEFINE (Bcons, 0102) \ -DEFINE (Blist1, 0103) \ -DEFINE (Blist2, 0104) \ -DEFINE (Blist3, 0105) \ -DEFINE (Blist4, 0106) \ -DEFINE (Blength, 0107) \ -DEFINE (Baref, 0110) \ -DEFINE (Baset, 0111) \ -DEFINE (Bsymbol_value, 0112) \ -DEFINE (Bsymbol_function, 0113) \ -DEFINE (Bset, 0114) \ -DEFINE (Bfset, 0115) \ -DEFINE (Bget, 0116) \ -DEFINE (Bsubstring, 0117) \ -DEFINE (Bconcat2, 0120) \ -DEFINE (Bconcat3, 0121) \ -DEFINE (Bconcat4, 0122) \ -DEFINE (Bsub1, 0123) \ -DEFINE (Badd1, 0124) \ -DEFINE (Beqlsign, 0125) \ -DEFINE (Bgtr, 0126) \ -DEFINE (Blss, 0127) \ -DEFINE (Bleq, 0130) \ -DEFINE (Bgeq, 0131) \ -DEFINE (Bdiff, 0132) \ -DEFINE (Bnegate, 0133) \ -DEFINE (Bplus, 0134) \ -DEFINE (Bmax, 0135) \ -DEFINE (Bmin, 0136) \ -DEFINE (Bmult, 0137) \ - \ -DEFINE (Bpoint, 0140) \ -/* Was Bmark in v17. */ \ -DEFINE (Bsave_current_buffer, 0141) /* Obsolete. */ \ -DEFINE (Bgoto_char, 0142) \ -DEFINE (Binsert, 0143) \ -DEFINE (Bpoint_max, 0144) \ -DEFINE (Bpoint_min, 0145) \ -DEFINE (Bchar_after, 0146) \ -DEFINE (Bfollowing_char, 0147) \ -DEFINE (Bpreceding_char, 0150) \ -DEFINE (Bcurrent_column, 0151) \ -DEFINE (Bindent_to, 0152) \ -DEFINE (Beolp, 0154) \ -DEFINE (Beobp, 0155) \ -DEFINE (Bbolp, 0156) \ -DEFINE (Bbobp, 0157) \ -DEFINE (Bcurrent_buffer, 0160) \ -DEFINE (Bset_buffer, 0161) \ -DEFINE (Bsave_current_buffer_1, 0162) /* Replacing Bsave_current_buffer. */ \ -DEFINE (Binteractive_p, 0164) /* Obsolete since Emacs-24.1. */ \ - \ -DEFINE (Bforward_char, 0165) \ -DEFINE (Bforward_word, 0166) \ -DEFINE (Bskip_chars_forward, 0167) \ -DEFINE (Bskip_chars_backward, 0170) \ -DEFINE (Bforward_line, 0171) \ -DEFINE (Bchar_syntax, 0172) \ -DEFINE (Bbuffer_substring, 0173) \ -DEFINE (Bdelete_region, 0174) \ -DEFINE (Bnarrow_to_region, 0175) \ -DEFINE (Bwiden, 0176) \ -DEFINE (Bend_of_line, 0177) \ - \ -DEFINE (Bconstant2, 0201) \ -DEFINE (Bgoto, 0202) \ -DEFINE (Bgotoifnil, 0203) \ -DEFINE (Bgotoifnonnil, 0204) \ -DEFINE (Bgotoifnilelsepop, 0205) \ -DEFINE (Bgotoifnonnilelsepop, 0206) \ -DEFINE (Breturn, 0207) \ -DEFINE (Bdiscard, 0210) \ -DEFINE (Bdup, 0211) \ - \ -DEFINE (Bsave_excursion, 0212) \ -DEFINE (Bsave_window_excursion, 0213) /* Obsolete since Emacs-24.1. */ \ -DEFINE (Bsave_restriction, 0214) \ -DEFINE (Bcatch, 0215) \ - \ -DEFINE (Bunwind_protect, 0216) \ -DEFINE (Bcondition_case, 0217) \ -DEFINE (Btemp_output_buffer_setup, 0220) /* Obsolete since Emacs-24.1. */ \ -DEFINE (Btemp_output_buffer_show, 0221) /* Obsolete since Emacs-24.1. */ \ - \ -DEFINE (Bunbind_all, 0222) /* Obsolete. Never used. */ \ - \ -DEFINE (Bset_marker, 0223) \ -DEFINE (Bmatch_beginning, 0224) \ -DEFINE (Bmatch_end, 0225) \ -DEFINE (Bupcase, 0226) \ -DEFINE (Bdowncase, 0227) \ - \ -DEFINE (Bstringeqlsign, 0230) \ -DEFINE (Bstringlss, 0231) \ -DEFINE (Bequal, 0232) \ -DEFINE (Bnthcdr, 0233) \ -DEFINE (Belt, 0234) \ -DEFINE (Bmember, 0235) \ -DEFINE (Bassq, 0236) \ -DEFINE (Bnreverse, 0237) \ -DEFINE (Bsetcar, 0240) \ -DEFINE (Bsetcdr, 0241) \ -DEFINE (Bcar_safe, 0242) \ -DEFINE (Bcdr_safe, 0243) \ -DEFINE (Bnconc, 0244) \ -DEFINE (Bquo, 0245) \ -DEFINE (Brem, 0246) \ -DEFINE (Bnumberp, 0247) \ -DEFINE (Bintegerp, 0250) \ - \ -DEFINE (BRgoto, 0252) \ -DEFINE (BRgotoifnil, 0253) \ -DEFINE (BRgotoifnonnil, 0254) \ -DEFINE (BRgotoifnilelsepop, 0255) \ -DEFINE (BRgotoifnonnilelsepop, 0256) \ - \ -DEFINE (BlistN, 0257) \ -DEFINE (BconcatN, 0260) \ -DEFINE (BinsertN, 0261) \ - \ -/* Bstack_ref is code 0. */ \ -DEFINE (Bstack_set, 0262) \ -DEFINE (Bstack_set2, 0263) \ -DEFINE (BdiscardN, 0266) \ - \ -DEFINE (Bswitch, 0267) \ - \ -DEFINE (Bconstant, 0300) - -enum byte_code_op -{ -#define DEFINE(name, value) name = value, - BYTE_CODES -#undef DEFINE - -#if BYTE_CODE_SAFE - Bscan_buffer = 0153, /* No longer generated as of v18. */ - Bset_mark = 0163, /* this loser is no longer generated as of v18 */ -#endif -}; /* Fetch the next byte from the bytecode stream. */ diff --git a/src/bytecode.h b/src/bytecode.h new file mode 100644 index 0000000000..07452eb185 --- /dev/null +++ b/src/bytecode.h @@ -0,0 +1,230 @@ +/* Byte code definitions + Copyright (C) 1985-1988, 1993, 2000-2018 Free Software Foundation, + Inc. + +This file is part of GNU Emacs. + +GNU Emacs is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or (at +your option) any later version. + +GNU Emacs is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Emacs. If not, see . */ + +#ifndef EMACS_BYTECODE_H +#define EMACS_BYTECODE_H + +/* Byte codes: */ + +#define BYTE_CODES \ +DEFINE (Bstack_ref, 0) /* Actually, Bstack_ref+0 is not implemented: use dup. */ \ +DEFINE (Bstack_ref1, 1) \ +DEFINE (Bstack_ref2, 2) \ +DEFINE (Bstack_ref3, 3) \ +DEFINE (Bstack_ref4, 4) \ +DEFINE (Bstack_ref5, 5) \ +DEFINE (Bstack_ref6, 6) \ +DEFINE (Bstack_ref7, 7) \ +DEFINE (Bvarref, 010) \ +DEFINE (Bvarref1, 011) \ +DEFINE (Bvarref2, 012) \ +DEFINE (Bvarref3, 013) \ +DEFINE (Bvarref4, 014) \ +DEFINE (Bvarref5, 015) \ +DEFINE (Bvarref6, 016) \ +DEFINE (Bvarref7, 017) \ +DEFINE (Bvarset, 020) \ +DEFINE (Bvarset1, 021) \ +DEFINE (Bvarset2, 022) \ +DEFINE (Bvarset3, 023) \ +DEFINE (Bvarset4, 024) \ +DEFINE (Bvarset5, 025) \ +DEFINE (Bvarset6, 026) \ +DEFINE (Bvarset7, 027) \ +DEFINE (Bvarbind, 030) \ +DEFINE (Bvarbind1, 031) \ +DEFINE (Bvarbind2, 032) \ +DEFINE (Bvarbind3, 033) \ +DEFINE (Bvarbind4, 034) \ +DEFINE (Bvarbind5, 035) \ +DEFINE (Bvarbind6, 036) \ +DEFINE (Bvarbind7, 037) \ +DEFINE (Bcall, 040) \ +DEFINE (Bcall1, 041) \ +DEFINE (Bcall2, 042) \ +DEFINE (Bcall3, 043) \ +DEFINE (Bcall4, 044) \ +DEFINE (Bcall5, 045) \ +DEFINE (Bcall6, 046) \ +DEFINE (Bcall7, 047) \ +DEFINE (Bunbind, 050) \ +DEFINE (Bunbind1, 051) \ +DEFINE (Bunbind2, 052) \ +DEFINE (Bunbind3, 053) \ +DEFINE (Bunbind4, 054) \ +DEFINE (Bunbind5, 055) \ +DEFINE (Bunbind6, 056) \ +DEFINE (Bunbind7, 057) \ + \ +DEFINE (Bpophandler, 060) \ +DEFINE (Bpushconditioncase, 061) \ +DEFINE (Bpushcatch, 062) \ + \ +DEFINE (Bnth, 070) \ +DEFINE (Bsymbolp, 071) \ +DEFINE (Bconsp, 072) \ +DEFINE (Bstringp, 073) \ +DEFINE (Blistp, 074) \ +DEFINE (Beq, 075) \ +DEFINE (Bmemq, 076) \ +DEFINE (Bnot, 077) \ +DEFINE (Bcar, 0100) \ +DEFINE (Bcdr, 0101) \ +DEFINE (Bcons, 0102) \ +DEFINE (Blist1, 0103) \ +DEFINE (Blist2, 0104) \ +DEFINE (Blist3, 0105) \ +DEFINE (Blist4, 0106) \ +DEFINE (Blength, 0107) \ +DEFINE (Baref, 0110) \ +DEFINE (Baset, 0111) \ +DEFINE (Bsymbol_value, 0112) \ +DEFINE (Bsymbol_function, 0113) \ +DEFINE (Bset, 0114) \ +DEFINE (Bfset, 0115) \ +DEFINE (Bget, 0116) \ +DEFINE (Bsubstring, 0117) \ +DEFINE (Bconcat2, 0120) \ +DEFINE (Bconcat3, 0121) \ +DEFINE (Bconcat4, 0122) \ +DEFINE (Bsub1, 0123) \ +DEFINE (Badd1, 0124) \ +DEFINE (Beqlsign, 0125) \ +DEFINE (Bgtr, 0126) \ +DEFINE (Blss, 0127) \ +DEFINE (Bleq, 0130) \ +DEFINE (Bgeq, 0131) \ +DEFINE (Bdiff, 0132) \ +DEFINE (Bnegate, 0133) \ +DEFINE (Bplus, 0134) \ +DEFINE (Bmax, 0135) \ +DEFINE (Bmin, 0136) \ +DEFINE (Bmult, 0137) \ + \ +DEFINE (Bpoint, 0140) \ +/* Was Bmark in v17. */ \ +DEFINE (Bsave_current_buffer, 0141) /* Obsolete. */ \ +DEFINE (Bgoto_char, 0142) \ +DEFINE (Binsert, 0143) \ +DEFINE (Bpoint_max, 0144) \ +DEFINE (Bpoint_min, 0145) \ +DEFINE (Bchar_after, 0146) \ +DEFINE (Bfollowing_char, 0147) \ +DEFINE (Bpreceding_char, 0150) \ +DEFINE (Bcurrent_column, 0151) \ +DEFINE (Bindent_to, 0152) \ +DEFINE (Beolp, 0154) \ +DEFINE (Beobp, 0155) \ +DEFINE (Bbolp, 0156) \ +DEFINE (Bbobp, 0157) \ +DEFINE (Bcurrent_buffer, 0160) \ +DEFINE (Bset_buffer, 0161) \ +DEFINE (Bsave_current_buffer_1, 0162) /* Replacing Bsave_current_buffer. */ \ +DEFINE (Binteractive_p, 0164) /* Obsolete since Emacs-24.1. */ \ + \ +DEFINE (Bforward_char, 0165) \ +DEFINE (Bforward_word, 0166) \ +DEFINE (Bskip_chars_forward, 0167) \ +DEFINE (Bskip_chars_backward, 0170) \ +DEFINE (Bforward_line, 0171) \ +DEFINE (Bchar_syntax, 0172) \ +DEFINE (Bbuffer_substring, 0173) \ +DEFINE (Bdelete_region, 0174) \ +DEFINE (Bnarrow_to_region, 0175) \ +DEFINE (Bwiden, 0176) \ +DEFINE (Bend_of_line, 0177) \ + \ +DEFINE (Bconstant2, 0201) \ +DEFINE (Bgoto, 0202) \ +DEFINE (Bgotoifnil, 0203) \ +DEFINE (Bgotoifnonnil, 0204) \ +DEFINE (Bgotoifnilelsepop, 0205) \ +DEFINE (Bgotoifnonnilelsepop, 0206) \ +DEFINE (Breturn, 0207) \ +DEFINE (Bdiscard, 0210) \ +DEFINE (Bdup, 0211) \ + \ +DEFINE (Bsave_excursion, 0212) \ +DEFINE (Bsave_window_excursion, 0213) /* Obsolete since Emacs-24.1. */ \ +DEFINE (Bsave_restriction, 0214) \ +DEFINE (Bcatch, 0215) \ + \ +DEFINE (Bunwind_protect, 0216) \ +DEFINE (Bcondition_case, 0217) \ +DEFINE (Btemp_output_buffer_setup, 0220) /* Obsolete since Emacs-24.1. */ \ +DEFINE (Btemp_output_buffer_show, 0221) /* Obsolete since Emacs-24.1. */ \ + \ +DEFINE (Bunbind_all, 0222) /* Obsolete. Never used. */ \ + \ +DEFINE (Bset_marker, 0223) \ +DEFINE (Bmatch_beginning, 0224) \ +DEFINE (Bmatch_end, 0225) \ +DEFINE (Bupcase, 0226) \ +DEFINE (Bdowncase, 0227) \ + \ +DEFINE (Bstringeqlsign, 0230) \ +DEFINE (Bstringlss, 0231) \ +DEFINE (Bequal, 0232) \ +DEFINE (Bnthcdr, 0233) \ +DEFINE (Belt, 0234) \ +DEFINE (Bmember, 0235) \ +DEFINE (Bassq, 0236) \ +DEFINE (Bnreverse, 0237) \ +DEFINE (Bsetcar, 0240) \ +DEFINE (Bsetcdr, 0241) \ +DEFINE (Bcar_safe, 0242) \ +DEFINE (Bcdr_safe, 0243) \ +DEFINE (Bnconc, 0244) \ +DEFINE (Bquo, 0245) \ +DEFINE (Brem, 0246) \ +DEFINE (Bnumberp, 0247) \ +DEFINE (Bintegerp, 0250) \ + \ +DEFINE (BRgoto, 0252) \ +DEFINE (BRgotoifnil, 0253) \ +DEFINE (BRgotoifnonnil, 0254) \ +DEFINE (BRgotoifnilelsepop, 0255) \ +DEFINE (BRgotoifnonnilelsepop, 0256) \ + \ +DEFINE (BlistN, 0257) \ +DEFINE (BconcatN, 0260) \ +DEFINE (BinsertN, 0261) \ + \ +/* Bstack_ref is code 0. */ \ +DEFINE (Bstack_set, 0262) \ +DEFINE (Bstack_set2, 0263) \ +DEFINE (BdiscardN, 0266) \ + \ +DEFINE (Bswitch, 0267) \ + \ +DEFINE (Bconstant, 0300) + +enum byte_code_op +{ +#define DEFINE(name, value) name = value, + BYTE_CODES +#undef DEFINE + +#if BYTE_CODE_SAFE + Bscan_buffer = 0153, /* No longer generated as of v18. */ + Bset_mark = 0163, /* this loser is no longer generated as of v18 */ +#endif +}; + +#endif /* EMACS_BYTECODE_H */ diff --git a/src/lisp.h b/src/lisp.h index 8674fe11a6..04e70f592f 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -2096,6 +2096,8 @@ union Aligned_Lisp_Subr }; verify (GCALIGNED (union Aligned_Lisp_Subr)); +#define SUBR_MAX_ARGS 9 + INLINE bool SUBRP (Lisp_Object a) { commit ea622e321d500715238214db9d8b994cffe8568e Author: Andrea Corallo Date: Sat May 11 14:56:56 2019 +0200 Add nativecomp option to configure diff --git a/configure.ac b/configure.ac index 24d21c7afd..d059b7d672 100644 --- a/configure.ac +++ b/configure.ac @@ -463,6 +463,7 @@ OPTION_DEFAULT_ON([gnutls],[don't use -lgnutls for SSL/TLS support]) OPTION_DEFAULT_ON([zlib],[don't compile with zlib decompression support]) OPTION_DEFAULT_ON([modules],[compile with dynamic modules support]) OPTION_DEFAULT_ON([threads],[don't compile with elisp threading support]) +OPTION_DEFAULT_ON([nativecomp],[don't 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)])], @@ -3670,6 +3671,17 @@ if test "${HAVE_ZLIB}" = "yes"; then fi AC_SUBST(LIBZ) +HAVE_LIBGCCJIT=no +LIBGCCJIT_LIB= +if test "${with_nativecomp}" != "no"; then + AC_CHECK_LIB(gccjit, gcc_jit_context_acquire, HAVE_LIBGCCJIT=yes, , -lgccjit) + if test "${HAVE_LIBGCCJIT}" = "yes"; then + LIBGCCJIT_LIB=-lgccjit + AC_DEFINE([HAVE_LIBGCCJIT], 1, [Define to 1 if you have the libgccjit library (-lgccjit).]) + fi +fi +AC_SUBST([LIBGCCJIT_LIB]) + ### Dynamic modules support LIBMODULES= HAVE_MODULES=no @@ -5714,6 +5726,7 @@ AS_ECHO([" Does Emacs use -lXaw3d? ${HAVE_XAW3D Does Emacs support the portable dumper? ${with_pdumper} Does Emacs support legacy unexec dumping? ${with_unexec} Which dumping strategy does Emacs use? ${with_dumping} + Does Emacs have native lisp compiler? ${with_nativecomp} "]) if test -n "${EMACSDATA}"; then diff --git a/src/Makefile.in b/src/Makefile.in index 423c5a3f92..4a66016e97 100644 --- a/src/Makefile.in +++ b/src/Makefile.in @@ -326,6 +326,8 @@ GETLOADAVG_LIBS = @GETLOADAVG_LIBS@ GMP_LIB = @GMP_LIB@ GMP_OBJ = @GMP_OBJ@ +LIBGCCJIT = @LIBGCCJIT_LIB@ + RUN_TEMACS = ./temacs # Whether builds should contain details. '--no-build-details' or empty. @@ -531,7 +533,7 @@ LIBES = $(LIBS) $(W32_LIBS) $(LIBS_GNUSTEP) $(LIBX_BASE) $(LIBIMAGE) \ $(FREETYPE_LIBS) $(FONTCONFIG_LIBS) $(HARFBUZZ_LIBS) $(LIBOTF_LIBS) $(M17N_FLT_LIBS) \ $(LIBGNUTLS_LIBS) $(LIB_PTHREAD) $(GETADDRINFO_A_LIBS) $(LCMS2_LIBS) \ $(NOTIFY_LIBS) $(LIB_MATH) $(LIBZ) $(LIBMODULES) $(LIBSYSTEMD_LIBS) \ - $(JSON_LIBS) $(GMP_LIB) + $(JSON_LIBS) $(GMP_LIB) $(LIBGCCJIT) ## FORCE it so that admin/unidata can decide whether this file is ## up-to-date. Although since charprop depends on bootstrap-emacs, commit 0f476b1de3c3e61467cff9536618d120873c47ab Author: Andrea Corallo Date: Fri May 10 16:26:18 2019 +0200 Move native C code into shared library diff --git a/lib/Makefile.in b/lib/Makefile.in index 06d8e56421..ed3123885d 100644 --- a/lib/Makefile.in +++ b/lib/Makefile.in @@ -26,6 +26,8 @@ abs_top_srcdir = @abs_top_srcdir@ top_builddir = @top_builddir@ top_srcdir = @top_srcdir@ +CFLAGS = -fPIC @CFLAGS@ + all: .PHONY: all @@ -50,7 +52,7 @@ am__v_at_ = $(am__v_at_@AM_DEFAULT_V@) am__v_at_0 = @ am__v_at_1 = -ALL_CFLAGS= \ +ALL_CFLAGS= -fPIC \ $(C_SWITCH_SYSTEM) $(C_SWITCH_MACHINE) $(DEPFLAGS) \ $(GNULIB_WARN_CFLAGS) $(WERROR_CFLAGS) $(PROFILING_CFLAGS) $(CFLAGS) \ -I. -I../src -I$(srcdir) -I$(srcdir)/../src \ diff --git a/src/Makefile.in b/src/Makefile.in index ab63b92627..423c5a3f92 100644 --- a/src/Makefile.in +++ b/src/Makefile.in @@ -33,7 +33,7 @@ top_srcdir = @top_srcdir@ abs_top_srcdir=@abs_top_srcdir@ VPATH = $(srcdir) CC = @CC@ -CFLAGS = @CFLAGS@ +CFLAGS = @CFLAGS@ -fPIC CPPFLAGS = @CPPFLAGS@ LDFLAGS = @LDFLAGS@ EXEEXT = @EXEEXT@ @@ -463,7 +463,7 @@ FIRSTFILE_OBJ=@FIRSTFILE_OBJ@ ALLOBJS = $(FIRSTFILE_OBJ) $(VMLIMIT_OBJ) $(obj) $(otherobj) # Must be first, before dep inclusion! -all: emacs$(EXEEXT) $(pdmp) $(OTHER_FILES) +all: $(pdmp) $(OTHER_FILES) .PHONY: all dmpstruct_headers=$(srcdir)/lisp.h $(srcdir)/buffer.h \ @@ -642,25 +642,33 @@ else MAKE_PDUMPER_FINGERPRINT = endif -## We have to create $(etc) here because init_cmdargs tests its -## existence when setting Vinstallation_directory (FIXME?). -## This goes on to affect various things, and the emacs binary fails -## to start if Vinstallation_directory has the wrong value. -temacs$(EXEEXT): $(LIBXMENU) $(ALLOBJS) $(LIBEGNU_ARCHIVE) $(EMACSRES) \ - $(charsets) $(charscript) $(MAKE_PDUMPER_FINGERPRINT) - $(AM_V_CCLD)$(CC) -o $@.tmp \ - $(ALL_CFLAGS) $(TEMACS_LDFLAGS) $(LDFLAGS) \ - $(ALLOBJS) $(LIBEGNU_ARCHIVE) $(W32_RES_LINK) $(LIBES) -ifeq ($(HAVE_PDUMPER),yes) - $(AM_V_at)$(MAKE_PDUMPER_FINGERPRINT) $@.tmp -endif - $(AM_V_at)mv $@.tmp $@ - $(MKDIR_P) $(etc) -ifeq ($(DUMPING),unexec) - ifneq ($(PAXCTL_notdumped),) - $(PAXCTL_notdumped) $@ - endif -endif +## FIXME: dumper support totally missing here +libemacs.so: $(LIBXMENU) $(ALLOBJS) $(LIBEGNU_ARCHIVE) $(EMACSRES) \ + $(charsets) $(charscript) $(MAKE_PDUMPER_FINGERPRINT) main.o + $(CC) --shared -o $@ $(ALLOBJS) -Wl,-Bstatic $(LIBEGNU_ARCHIVE) -Wl,-Bdynamic $(LIBES) + +temacs$(EXEEXT): libemacs.so main.o + $(CC) -L. main.o -o $@ $(TEMACS_LDFLAGS) $(LDFLAGS) \ + $(ALLOBJS) $(LIBEGNU_ARCHIVE) $(W32_RES_LINK) $(LIBES) -lemacs -Wl,-rpath -Wl,$(shell pwd) + +# ## We have to create $(etc) here because init_cmdargs tests its +# ## existence when setting Vinstallation_directory (FIXME?). +# ## This goes on to affect various things, and the emacs binary fails +# ## to start if Vinstallation_directory has the wrong value. +# temacs$(EXEEXT): $(LIBXMENU) $(ALLOBJS) $(LIBEGNU_ARCHIVE) $(EMACSRES) \ +# $(charsets) $(charscript) $(MAKE_PDUMPER_FINGERPRINT) +# $(AM_V_CCLD)$(CC) -o $@.tmp \ +# $(ALL_CFLAGS) $(TEMACS_LDFLAGS) $(LDFLAGS) \ +# $(ALLOBJS) $(LIBEGNU_ARCHIVE) $(W32_RES_LINK) $(LIBES) +# ifeq ($(HAVE_PDUMPER),yes) +# $(AM_V_at)$(MAKE_PDUMPER_FINGERPRINT) $@.tmp +# endif +# $(AM_V_at)mv $@.tmp $@ +# $(MKDIR_P) $(etc) +# ifeq ($(DUMPING),unexec) +# ifneq ($(PAXCTL_notdumped),) +# $(PAXCTL_notdumped) $@ +# endif ## The following oldxmenu-related rules are only (possibly) used if ## HAVE_X11 && !USE_GTK, but there is no harm in always defining them. diff --git a/src/emacs.c b/src/emacs.c index c5a760d29f..81703b4660 100644 --- a/src/emacs.c +++ b/src/emacs.c @@ -924,7 +924,7 @@ load_pdump (int argc, char **argv) #endif /* HAVE_PDUMPER */ int -main (int argc, char **argv) +main1 (int argc, char **argv) { /* Variable near the bottom of the stack, and aligned appropriately for pointers. */ diff --git a/src/main.c b/src/main.c new file mode 100644 index 0000000000..41e3553428 --- /dev/null +++ b/src/main.c @@ -0,0 +1,26 @@ +/* Trampoline for GNU Emacs. + Copyright (C) 2019 Free Software + Foundation, Inc. + +This file is part of GNU Emacs. + +GNU Emacs is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or (at +your option) any later version. + +GNU Emacs is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Emacs. If not, see . */ + +extern int main1 (int argc, char **argv); + +int +main (int argc, char **argv) +{ + return main1(argc, argv); +}