commit 3f383a4668e6b9e45067389c997a5b1f4cddd3fd (HEAD, refs/remotes/origin/master) Author: Glenn Morris Date: Mon Feb 13 23:36:17 2017 -0800 Remove overly broad element from default mail-dont-reply-to-names * lisp/mail/mail-utils.el (mail-dont-reply-to): Do not include just "user@" in mail-dont-reply-to-names, and simplify. Ref: lists.gnu.org/archive/html/help-gnu-emacs/2017-02/msg00049.html * lisp/gnus/message.el (message-dont-reply-to-names): Doc fix. * doc/misc/message.texi (Wide Reply): Tiny fix re dont-reply-to-names. diff --git a/doc/misc/message.texi b/doc/misc/message.texi index 27a159d4a9..bbdef4a862 100644 --- a/doc/misc/message.texi +++ b/doc/misc/message.texi @@ -185,8 +185,8 @@ but you can change the behavior to suit your needs by fiddling with the @vindex message-dont-reply-to-names Addresses that match the @code{message-dont-reply-to-names} regular expression (or list of regular expressions or a predicate function) -will be removed from the @code{Cc} header. A value of @code{nil} means -exclude your name only. +will be removed from the @code{Cc} header. A value of @code{nil} means +to exclude only your email address. @vindex message-prune-recipient-rules @code{message-prune-recipient-rules} is used to prune the addresses diff --git a/lisp/gnus/message.el b/lisp/gnus/message.el index ce0dad9cb0..2819269122 100644 --- a/lisp/gnus/message.el +++ b/lisp/gnus/message.el @@ -1358,7 +1358,7 @@ If nil, you might be asked to input the charset." (defcustom message-dont-reply-to-names mail-dont-reply-to-names "Addresses to prune when doing wide replies. This can be a regexp, a list of regexps or a predicate function. -Also, a value of nil means exclude your own user name only. +Also, a value of nil means exclude `user-mail-address' only. If a function email is passed as the argument." :version "24.3" diff --git a/lisp/mail/mail-utils.el b/lisp/mail/mail-utils.el index 3cadf12af1..c23af87365 100644 --- a/lisp/mail/mail-utils.el +++ b/lisp/mail/mail-utils.el @@ -237,21 +237,12 @@ comma-separated list, and return the pruned list." ;; Or just set the default directly in the defcustom. (if (null mail-dont-reply-to-names) (setq mail-dont-reply-to-names - (concat ;; `rmail-default-dont-reply-to-names' is obsolete. - (if (bound-and-true-p rmail-default-dont-reply-to-names) - (concat rmail-default-dont-reply-to-names "\\|") - "") - (if (and user-mail-address - (not (equal user-mail-address user-login-name))) - ;; Anchor the login name and email address so that we - ;; don't match substrings: if the login name is - ;; "foo", we shouldn't match "barfoo@baz.com". - (concat "\\`" - (regexp-quote user-mail-address) - "\\'\\|") - "") - (concat "\\`" (regexp-quote user-login-name) "@")))) + (let ((a (bound-and-true-p rmail-default-dont-reply-to-names)) + (b (if (> (length user-mail-address) 0) + (concat "\\`" (regexp-quote user-mail-address) "\\'")))) + (cond ((and a b) (concat a "\\|" b)) + ((or a b)))))) ;; Split up DESTINATIONS and match each element separately. (let ((start-pos 0) (cur-pos 0) (case-fold-search t)) @@ -271,7 +262,8 @@ comma-separated list, and return the pruned list." (setq cur-pos start-pos))) (let* ((address (substring destinations start-pos cur-pos)) (naked-address (mail-strip-quoted-names address))) - (if (string-match mail-dont-reply-to-names naked-address) + (if (and mail-dont-reply-to-names + (string-match mail-dont-reply-to-names naked-address)) (setq destinations (concat (substring destinations 0 start-pos) (and cur-pos (substring destinations (1+ cur-pos)))) commit 31b4d9a13741caae2422636d4944212e702b19c3 Author: Juri Linkov Date: Tue Feb 14 02:04:28 2017 +0200 * etc/NEWS: Mention query-replace-from-to-separator. (Bug#25482) diff --git a/etc/NEWS b/etc/NEWS index cba4e4d9a8..31b05ddbab 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -724,6 +724,13 @@ mode bindings: 'C-c @ C-a', 'C-c @ C-t', 'C-c @ C-d', and 'C-c @ C-e.' before running. This is controlled by the 'grep-save-buffers' variable. +--- +** Customizable variable 'query-replace-from-to-separator' +now doesn't propertize the string value of the separator. +Instead, text properties are added by query-replace-read-from. +Additionally, the new nil value restores pre-24.5 behavior +of not providing replacement pairs via the history. + ** Some obsolete functions, variables, and faces have been removed: *** make-variable-frame-local. Variables cannot be frame-local any more. *** From subr.el: window-dot, set-window-dot, read-input, show-buffer, commit fffd4ffd747fe46bb7849a874e4ae265b6eda54e Author: Vibhav Pant Date: Mon Feb 13 22:54:05 2017 +0530 ; etc/TODO: Remove 'switch' item, as it is now implemented. diff --git a/etc/TODO b/etc/TODO index fc442f9307..b102bdf35f 100644 --- a/etc/TODO +++ b/etc/TODO @@ -35,20 +35,6 @@ Change src/bytecode.c so that calls from byte-code functions to byte-code functions don't go through Ffuncall/funcall_lambda/exec_byte_code but instead stay within exec_byte_code. -** Add new 'switch' byte-code -This byte-code would take one argument from the stack (the object to test) -and one argument from the constant-pool (a switch table, implemented as an -'eq' hash table) and would jump to the "label" contained in the hash table. - -Then add a 'case' special-form that can be compiled to this byte-code. -This would behave just like cl-case, but instead of expanding to cond+eq it -would be its own special form and would be compiled specially. - -Then change pcase to use 'case' when applicable. - -Then change the byte-compiler to recognize (cond ((eq x 'foo) bar) ...) -and turn it into a 'case' for more efficient execution. - ** Improve the byte-compiler to recognize immutable (lexical) bindings and get rid of them if they're used only once and/or they're bound to a constant expression. commit 271dcf8652ccf94d8582b2bcdb26f066d0b946a2 Author: Arash Esbati Date: Mon Feb 13 09:22:12 2017 +0100 Match all characters in optional argument of \documentclass * lisp/textmodes/reftex.el (reftex-TeX-master-file): Match all characters in optional argument containing name of the main file. diff --git a/lisp/textmodes/reftex.el b/lisp/textmodes/reftex.el index 18b35981f8..9754d2b20f 100644 --- a/lisp/textmodes/reftex.el +++ b/lisp/textmodes/reftex.el @@ -352,7 +352,7 @@ If the symbols for the current master file do not exist, they are created." ((save-excursion (goto-char (point-min)) (re-search-forward - "^[[:space:]]*\\\\documentclass\\[\\([[:word:].]+\\)\\]{subfiles}" + "^[[:space:]]*\\\\documentclass\\[\\([^]]+\\)\\]{subfiles}" nil t)) (match-string-no-properties 1)) ;; AUCTeX is loaded. Use its mechanism. commit cb410433e069b5bb450193353c3fea8593a643a9 (refs/remotes/origin/feature/byte-switch) Merge: e742450427 4b18ef7ba3 Author: Vibhav Pant Date: Mon Feb 13 17:07:36 2017 +0530 Merge branch 'master' into feature/byte-switch commit e742450427007cdde242c11380dfe32a950fab61 Author: Vibhav Pant Date: Mon Feb 13 16:44:06 2017 +0530 ; Add more documentation for byte-switch related code. diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el index 3bec3e61df..38f5dcc993 100644 --- a/lisp/emacs-lisp/byte-opt.el +++ b/lisp/emacs-lisp/byte-opt.el @@ -1421,6 +1421,8 @@ when (and (listp el) ;; make sure we're at the correct op (eq (nth 1 el) 'byte-constant) (eq (nth 2 el) orig-table)) + ;; jump tables are never resused, so we do this exactly + ;; once. do (setf (nth 2 el) last-constant) and return nil)))) ;; lap = ( [ (pc . (op . arg)) ]* ) (push (cons optr (cons bytedecomp-op (or offset 0))) diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 14678e91ee..6e8442291f 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -3135,8 +3135,8 @@ for symbols generated by the byte compiler itself." ;; lexical-binding, but it's not true in general, and it's not true for ;; code output by bytecomp.el with lexical-binding. ;; We also restore the value of `byte-compile-depth' and remove TAG depths - ;; accordingly when inlining byte-switch lap code, as documented in - ;; `byte-compile-cond-jump-table'. + ;; accordingly when inlining lapcode containing lap-code, exactly as + ;; documented in `byte-compile-cond-jump-table'. (let ((endtag (byte-compile-make-tag)) last-jump-tag ;; last TAG we have jumped to last-depth ;; last value of `byte-compile-depth' @@ -3150,8 +3150,12 @@ for symbols generated by the byte compiler itself." (cond ((eq (car op) 'TAG) (when (or (member op switch-tags) (member op switch-default-tags)) + ;; This TAG is used in a jump table, this means the last goto + ;; was to a done/default TAG, and thus it's cddr should be set to nil. (when last-jump-tag (setcdr (cdr last-jump-tag) nil)) + ;; Also, restore the value of `byte-compile-depth' to what it was + ;; before the last goto. (setq byte-compile-depth last-depth last-jump-tag nil)) (byte-compile-out-tag op)) @@ -3160,6 +3164,8 @@ for symbols generated by the byte compiler itself." last-jump-tag (cdr op)) (byte-compile-goto (car op) (cdr op)) (when last-switch + ;; The last op was byte-switch, this goto jumps to a "default" TAG + ;; (when no value in the jump table is satisfied). (push (cdr op) switch-default-tags) (setcdr (cdr (cdr op)) nil) (setq byte-compile-depth last-depth @@ -3169,8 +3175,10 @@ for symbols generated by the byte compiler itself." (byte-compile-goto 'byte-goto endtag)) (t (when (eq (car op) 'byte-switch) + ;; The last constant is a jump table. (push last-constant byte-compile-jump-tables) (setq last-switch t) + ;; Push all TAGs in the jump to switch-tags. (maphash #'(lambda (_k tag) (push tag switch-tags)) last-constant)) @@ -4018,7 +4026,7 @@ that suppresses all warnings during execution of BODY." The condition for each clause is of the form (TEST VAR VALUE). VAR is a variable. TEST and VAR are the same throughout all conditions. -VALUE is either a constant or a quoted form. +VALUE satisfies `macroexp-const-p'. Return a list of the form ((TEST . VAR) ((VALUE BODY) ...))" (let ((cases '()) commit c24e8290fa4ec18c04cbedffbe741b53de280dd6 Author: Vibhav Pant Date: Mon Feb 13 13:18:54 2017 +0530 test/lisp/emacs-lisp/bytecomp-tests.el: Add more tests for switch. diff --git a/test/lisp/emacs-lisp/bytecomp-tests.el b/test/lisp/emacs-lisp/bytecomp-tests.el index 2233b28d33..acf9343914 100644 --- a/test/lisp/emacs-lisp/bytecomp-tests.el +++ b/test/lisp/emacs-lisp/bytecomp-tests.el @@ -253,7 +253,12 @@ bytecompiled code, and their results compared.") (let ((a 'three)) (cond ((eq a 'one) 1) ((eq a 2) 'two) ((eq a 'three) 3) (t t))) (let ((a 2)) (cond ((eq a 'one) 1) ((eq a 1) 'one) ((eq a 2) 'two) - (t nil)))) + (t nil))) + (let ((a 2.0)) (cond ((eql a 2) 'incorrect) ((eql a 2.00) 'correct))) + (let ((a "foobar")) (cond ((equal "notfoobar" a) 'incorrect) + ((equal 1 a) 'incorrect) + ((equal a "foobar") 'correct) + (t 'incorrect)))) "List of expressions for testing byte-switch.") (defun bytecomp-check-1 (pat) commit 219339e2eb332fc913f898e799d6532a7633a1d3 Author: Vibhav Pant Date: Sun Feb 12 13:24:55 2017 +0530 ; lisp/emacs-lisp/bytecomp.el: Fix indentation. diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 748a8cd01f..14678e91ee 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -4707,7 +4707,7 @@ binding slots have been popped." (and byte-compile-depth (not (= (cdr (cdr tag)) byte-compile-depth)) (error "Compiler bug: depth conflict at tag %d" (car (cdr tag)))) - (setq byte-compile-depth (cdr (cdr tag)))) + (setq byte-compile-depth (cdr (cdr tag)))) (setcdr (cdr tag) byte-compile-depth))) (defun byte-compile-goto (opcode tag) commit e27351e5ddeb9366e25f7c341684d79c487074ce Author: Vibhav Pant Date: Sat Feb 11 23:41:56 2017 +0530 src/bytecode.c (exec_byte_code): Make hash_code a Lisp_Object. This avoids using XUINT every time while comparing it with HASH_HASH (h, i), replacing it with EQ. diff --git a/src/bytecode.c b/src/bytecode.c index 156265faee..af94d03b17 100644 --- a/src/bytecode.c +++ b/src/bytecode.c @@ -1428,11 +1428,13 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, if (h->count <= 5) { /* Do a linear search if there are not many cases FIXME: 5 is arbitrarily chosen. */ - EMACS_UINT hash_code = h->test.hashfn (&h->test, v1); + Lisp_Object hash_code = h->test.cmpfn + ? make_number(h->test.hashfn (&h->test, v1)) : Qnil; + for (i = h->count; 0 <= --i;) if (EQ (v1, HASH_KEY (h, i)) || (h->test.cmpfn - && hash_code == XUINT (HASH_HASH (h, i)) + && EQ (hash_code, HASH_HASH (h, i)) && h->test.cmpfn (&h->test, v1, HASH_KEY (h, i)))) break; commit a35335c767fd7915e4203b3bba60d9c66df7a116 Author: Vibhav Pant Date: Sat Feb 11 23:09:47 2017 +0530 src/bytecode.c (exec_byte_code): Remove unnecessary (e)assert. diff --git a/src/bytecode.c b/src/bytecode.c index 8bc1ecfeaa..156265faee 100644 --- a/src/bytecode.c +++ b/src/bytecode.c @@ -1422,11 +1422,9 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, Lisp_Object v1 = POP; ptrdiff_t i; struct Lisp_Hash_Table *h = XHASH_TABLE(jmp_table); - /* Hash tables for switch are declared with :size set to the - exact number of cases. */ - if (BYTE_CODE_SAFE) - eassert (HASH_TABLE_SIZE (h) == h->count); + /* h->count is a faster approximation for HASH_TABLE_SIZE (h) + here. */ if (h->count <= 5) { /* Do a linear search if there are not many cases FIXME: 5 is arbitrarily chosen. */ commit 245fb2529bc4394003a020d6c43b8bcc1d6237ba Author: Vibhav Pant Date: Sat Feb 11 20:36:30 2017 +0530 ; src/bytecode.c (exec_byte_code): Refactor byte-switch code. Remove unnecessary asserts, remove duplicate code. diff --git a/src/bytecode.c b/src/bytecode.c index 29674a0d9d..8bc1ecfeaa 100644 --- a/src/bytecode.c +++ b/src/bytecode.c @@ -1431,29 +1431,22 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, { /* Do a linear search if there are not many cases FIXME: 5 is arbitrarily chosen. */ EMACS_UINT hash_code = h->test.hashfn (&h->test, v1); - for (i = 0; i < h->count; i++) - { - if (BYTE_CODE_SAFE) - eassert (!NILP (HASH_HASH (h, i))); - - if (EQ (v1, HASH_KEY (h, i)) - || (h->test.cmpfn - && hash_code == XUINT (HASH_HASH (h, i)) - && h->test.cmpfn (&h->test, v1, HASH_KEY (h, i)))) - { - op = XINT (HASH_VALUE (h, i)); - goto op_branch; - } - } + for (i = h->count; 0 <= --i;) + if (EQ (v1, HASH_KEY (h, i)) + || (h->test.cmpfn + && hash_code == XUINT (HASH_HASH (h, i)) + && h->test.cmpfn (&h->test, v1, HASH_KEY (h, i)))) + break; + } else - { - i = hash_lookup(h, v1, NULL); - if (i >= 0) { - op = XINT(HASH_VALUE (h, i)); - goto op_branch; - } - } + i = hash_lookup(h, v1, NULL); + + if (i >= 0) + { + op = XINT (HASH_VALUE (h, i)); + goto op_branch; + } } NEXT; commit 7c2d493540b6e2e1661397812c5ed9fcff04e36c Author: Vibhav Pant Date: Sat Feb 11 20:13:54 2017 +0530 src/bytecode.c: Add optional sanity check for jump tables. * src/bytecode.c (exec_byte_code): When sanity checks are enabled, check that the jump table's size is equal to it's count. diff --git a/src/bytecode.c b/src/bytecode.c index f3eab60c59..29674a0d9d 100644 --- a/src/bytecode.c +++ b/src/bytecode.c @@ -1422,14 +1422,15 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, Lisp_Object v1 = POP; ptrdiff_t i; struct Lisp_Hash_Table *h = XHASH_TABLE(jmp_table); + /* Hash tables for switch are declared with :size set to the + exact number of cases. */ + if (BYTE_CODE_SAFE) + eassert (HASH_TABLE_SIZE (h) == h->count); if (h->count <= 5) { /* Do a linear search if there are not many cases FIXME: 5 is arbitrarily chosen. */ EMACS_UINT hash_code = h->test.hashfn (&h->test, v1); - /* Hash tables for switch are declared with :size set to the - exact number of cases, thus - HASH_TABLE_SIZE (h) == h->count. */ for (i = 0; i < h->count; i++) { if (BYTE_CODE_SAFE) commit c1a9b5db0e2985e7c46fb3b1e50e9d17785f7fa3 Merge: a75d080b17 ac83b2dfe4 Author: Vibhav Pant Date: Sat Feb 11 19:54:37 2017 +0530 Merge branch 'master' into feature/byte-switch commit a75d080b17a6b6c6296ff4e24d8129d77bb3bb6b Author: Vibhav Pant Date: Sat Feb 11 18:17:57 2017 +0530 * src/bytecode.c: Refactor to follow GNU coding standards diff --git a/src/bytecode.c b/src/bytecode.c index 1ac2811032..f3eab60c59 100644 --- a/src/bytecode.c +++ b/src/bytecode.c @@ -1420,9 +1420,6 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, search as the jump table. */ Lisp_Object jmp_table = POP; Lisp_Object v1 = POP; -#ifdef BYTE_CODE_SAFE - CHECK_TYPE (HASH_TABLE_P (jmp_table), Qhash_table_p, jmp_table); -#endif ptrdiff_t i; struct Lisp_Hash_Table *h = XHASH_TABLE(jmp_table); @@ -1430,19 +1427,18 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, { /* Do a linear search if there are not many cases FIXME: 5 is arbitrarily chosen. */ EMACS_UINT hash_code = h->test.hashfn (&h->test, v1); + /* Hash tables for switch are declared with :size set to the + exact number of cases, thus + HASH_TABLE_SIZE (h) == h->count. */ for (i = 0; i < h->count; i++) { -#ifdef BYTE_CODE_SAFE - eassert (!NILP (HASH_HASH (h, i))); -#endif - /* Hash tables for switch are declared with :size set to the - exact number of cases, thus - HASH_TABLE_SIZE (h) == h->count. */ - - if ((EQ (v1, HASH_KEY (h, i)) || - (h->test.cmpfn - && hash_code == XUINT (HASH_HASH (h, i)) - && h->test.cmpfn (&h->test, v1, HASH_KEY (h, i))))) + if (BYTE_CODE_SAFE) + eassert (!NILP (HASH_HASH (h, i))); + + if (EQ (v1, HASH_KEY (h, i)) + || (h->test.cmpfn + && hash_code == XUINT (HASH_HASH (h, i)) + && h->test.cmpfn (&h->test, v1, HASH_KEY (h, i)))) { op = XINT (HASH_VALUE (h, i)); goto op_branch; commit dcd0e6fe3ae24a716e1f665b12d877681bb8cc21 Author: Vibhav Pant Date: Fri Feb 10 23:25:42 2017 +0530 src/bytecode.c: Avoid comparing values unnecessarily in Bswitch * src/bytecode.c: (exec_byte_code) While linear searching the jump table, compare the value's hash table first to avoid calling h->test.cmpfn every time. diff --git a/src/bytecode.c b/src/bytecode.c index ed1eb17846..1ac2811032 100644 --- a/src/bytecode.c +++ b/src/bytecode.c @@ -1429,6 +1429,7 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, if (h->count <= 5) { /* Do a linear search if there are not many cases FIXME: 5 is arbitrarily chosen. */ + EMACS_UINT hash_code = h->test.hashfn (&h->test, v1); for (i = 0; i < h->count; i++) { #ifdef BYTE_CODE_SAFE @@ -1439,8 +1440,9 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, HASH_TABLE_SIZE (h) == h->count. */ if ((EQ (v1, HASH_KEY (h, i)) || - (h->test.cmpfn && - h->test.cmpfn (&h->test, v1, HASH_KEY (h, i))))) + (h->test.cmpfn + && hash_code == XUINT (HASH_HASH (h, i)) + && h->test.cmpfn (&h->test, v1, HASH_KEY (h, i))))) { op = XINT (HASH_VALUE (h, i)); goto op_branch; commit 2d10d4ad1a24727b9c1db6664bc8f92eaa3fd4c8 Author: Vibhav Pant Date: Thu Feb 9 21:56:57 2017 +0530 src/bytecode.c (exec_byte_code): Remove unneeded assert. diff --git a/src/bytecode.c b/src/bytecode.c index 299c651b90..ed1eb17846 100644 --- a/src/bytecode.c +++ b/src/bytecode.c @@ -1426,12 +1426,6 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, ptrdiff_t i; struct Lisp_Hash_Table *h = XHASH_TABLE(jmp_table); -#ifdef BYTE_CODE_SAFE - /* Hash tables for switch are declared with :size set to exact - number of cases, so this should always be true. */ - eassert (HASH_TABLE_SIZE (h) == h->count); -#endif - if (h->count <= 5) { /* Do a linear search if there are not many cases FIXME: 5 is arbitrarily chosen. */ @@ -1440,6 +1434,10 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, #ifdef BYTE_CODE_SAFE eassert (!NILP (HASH_HASH (h, i))); #endif + /* Hash tables for switch are declared with :size set to the + exact number of cases, thus + HASH_TABLE_SIZE (h) == h->count. */ + if ((EQ (v1, HASH_KEY (h, i)) || (h->test.cmpfn && h->test.cmpfn (&h->test, v1, HASH_KEY (h, i))))) commit 13eabbd80b121d0b86de55321bd5dda5d99fb857 Author: Vibhav Pant Date: Thu Feb 9 19:12:59 2017 +0530 bytecode.c (exec_byte_code): Use h->count instead of HASH_TABLE_SIZE diff --git a/src/bytecode.c b/src/bytecode.c index fb10a6d691..299c651b90 100644 --- a/src/bytecode.c +++ b/src/bytecode.c @@ -1425,10 +1425,17 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, #endif ptrdiff_t i; struct Lisp_Hash_Table *h = XHASH_TABLE(jmp_table); - if (HASH_TABLE_SIZE (h) <= 5) + +#ifdef BYTE_CODE_SAFE + /* Hash tables for switch are declared with :size set to exact + number of cases, so this should always be true. */ + eassert (HASH_TABLE_SIZE (h) == h->count); +#endif + + if (h->count <= 5) { /* Do a linear search if there are not many cases FIXME: 5 is arbitrarily chosen. */ - for (i = 0; i < HASH_TABLE_SIZE (h); i++) + for (i = 0; i < h->count; i++) { #ifdef BYTE_CODE_SAFE eassert (!NILP (HASH_HASH (h, i))); commit 3189f954ebdf739831a40e1b336505da60ea66c6 Author: Vibhav Pant Date: Thu Feb 9 18:43:31 2017 +0530 bytecode.c (exec_byte_code): don't check hash code in linear search. * src/bytecode.c (exec_byte_code): Don't check that the hash code is not nil when linear scanning the jump table. Hash tables for are declared with :size as the exact number of cases, so each entry i should have a hash code. When BYTE_CODE_SAFE, do it as a sanity check. diff --git a/src/bytecode.c b/src/bytecode.c index 9bb7bd4e68..fb10a6d691 100644 --- a/src/bytecode.c +++ b/src/bytecode.c @@ -1430,8 +1430,10 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, FIXME: 5 is arbitrarily chosen. */ for (i = 0; i < HASH_TABLE_SIZE (h); i++) { - if (!NILP (HASH_HASH (h, i)) && - (EQ (v1, HASH_KEY (h, i)) || +#ifdef BYTE_CODE_SAFE + eassert (!NILP (HASH_HASH (h, i))); +#endif + if ((EQ (v1, HASH_KEY (h, i)) || (h->test.cmpfn && h->test.cmpfn (&h->test, v1, HASH_KEY (h, i))))) { commit dde800c8c9ea198996229d03df1fc45c7d057339 Author: Vibhav Pant Date: Thu Feb 9 12:18:54 2017 +0530 Improve byte-switch execution. * lisp/emacs-lisp/byte-opt.el, lisp/emacs-lisp/bytecomp.el (byte-decompile-bytecode-1), (byte-compile-lapcode): Calculate the actual jump address while compiling, store it in the jump table. * src/bytecode.c: Jump to the looked up value directly, do a linear search when the number of elements is <= 5. diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el index 888a5f8500..3bec3e61df 100644 --- a/lisp/emacs-lisp/byte-opt.el +++ b/lisp/emacs-lisp/byte-opt.el @@ -1411,10 +1411,8 @@ ;; Replace all addresses with TAGs. (maphash #'(lambda (value tag) (let (newtag) - (cl-assert (consp tag) - nil "Invalid address for byte-switch") (setq newtag (byte-compile-make-tag)) - (push (cons (+ (car tag) (lsh (cdr tag) 8)) newtag) tags) + (push (cons tag newtag) tags) (puthash value newtag last-constant))) last-constant) ;; Replace the hash table referenced in the lapcode with our diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index d5a163e5fd..748a8cd01f 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -917,10 +917,11 @@ CONST2 may be evaluated multiple times." (if (> (car bytes-tail) 255) (error "Bytecode overflow"))) (dolist (hash-table byte-compile-jump-tables) - (cl-loop for k being the hash-keys of hash-table do - (let ((tag (cdr (gethash k hash-table)))) - (setq pc (car tag)) - (puthash k (cons (logand pc 255) (lsh pc -8)) hash-table)))) + (maphash #'(lambda (value tag) + (setq pc (cadr tag)) + (puthash value (+ (logand pc 255) (lsh (lsh pc -8) 8)) + hash-table)) + hash-table)) (apply 'unibyte-string (nreverse bytes)))) diff --git a/src/bytecode.c b/src/bytecode.c index f9531761b3..9bb7bd4e68 100644 --- a/src/bytecode.c +++ b/src/bytecode.c @@ -1415,20 +1415,39 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, CASE (Bswitch): { + /*TODO: Perhaps introduce another byte-code for switch when the + number of cases is less, which uses a simple vector for linear + search as the jump table. */ Lisp_Object jmp_table = POP; Lisp_Object v1 = POP; #ifdef BYTE_CODE_SAFE CHECK_TYPE (HASH_TABLE_P (jmp_table), Qhash_table_p, jmp_table); #endif + ptrdiff_t i; struct Lisp_Hash_Table *h = XHASH_TABLE(jmp_table); - ptrdiff_t i = hash_lookup(h, v1, NULL); - if (i >= 0) { - Lisp_Object dest = HASH_VALUE(h, i); - int car = XINT(XCAR(dest)); - int cdr = XINT(XCDR(dest)); - op = car + (cdr << 8); /* Simulate FETCH2 */ - goto op_branch; - } + if (HASH_TABLE_SIZE (h) <= 5) + { /* Do a linear search if there are not many cases + FIXME: 5 is arbitrarily chosen. */ + for (i = 0; i < HASH_TABLE_SIZE (h); i++) + { + if (!NILP (HASH_HASH (h, i)) && + (EQ (v1, HASH_KEY (h, i)) || + (h->test.cmpfn && + h->test.cmpfn (&h->test, v1, HASH_KEY (h, i))))) + { + op = XINT (HASH_VALUE (h, i)); + goto op_branch; + } + } + } + else + { + i = hash_lookup(h, v1, NULL); + if (i >= 0) { + op = XINT(HASH_VALUE (h, i)); + goto op_branch; + } + } } NEXT; commit 96c4e367f973626cbab38af55a2c448b7274eeee Author: Vibhav Pant Date: Tue Feb 7 19:35:20 2017 +0530 Add tests for checking byte-switch code. * test/lisp/emacs-lisp/bytecomp-tests.el (bytecomp-cond): New test, test byte-switch bytecode. diff --git a/test/lisp/emacs-lisp/bytecomp-tests.el b/test/lisp/emacs-lisp/bytecomp-tests.el index bc47c82c1e..2233b28d33 100644 --- a/test/lisp/emacs-lisp/bytecomp-tests.el +++ b/test/lisp/emacs-lisp/bytecomp-tests.el @@ -247,6 +247,15 @@ Each element will be executed by interpreter and with bytecompiled code, and their results compared.") +(defconst byte-opt-testsuite-cond-data + '( + (let ((a 3)) (cond ((eq a 1) 'one) ((eq a 2) 'two) ((eq a 3) 'three) (t t))) + (let ((a 'three)) (cond ((eq a 'one) 1) ((eq a 2) 'two) ((eq a 'three) 3) + (t t))) + (let ((a 2)) (cond ((eq a 'one) 1) ((eq a 1) 'one) ((eq a 2) 'two) + (t nil)))) + "List of expressions for testing byte-switch.") + (defun bytecomp-check-1 (pat) "Return non-nil if PAT is the same whether directly evalled or compiled." (let ((warning-minimum-log-level :emergency) @@ -276,6 +285,11 @@ bytecompiled code, and their results compared.") (dolist (pat byte-opt-testsuite-arith-data) (should (bytecomp-check-1 pat)))) +(ert-deftest bytecomp-cond () + "Test the Emacs byte compiler." + (dolist (pat byte-opt-testsuite-cond-data) + (should (bytecomp-check-1 pat)))) + (defun test-byte-opt-arithmetic (&optional arg) "Unit test for byte-opt arithmetic operations. Subtests signal errors if something goes wrong." commit c4316a266185c4adbb8d15a04b9552882b3c34a8 Author: Vibhav Pant Date: Mon Feb 6 19:33:01 2017 +0530 ; bytecomp.el (byte-compile-cond-jump-table): Add TODO note diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index c70e1bf5ed..d5a163e5fd 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -4057,6 +4057,8 @@ Return a list of the form ((TEST . VAR) ((VALUE BODY) ...))" (cases (cadr table-info)) jump-table test-obj body tag donetag default-tag default-case) (when (and cases (not (= (length cases) 1))) + ;; TODO: Once :linear-search is implemented for `make-hash-table' + ;; set it to `t' for cond forms with a small number of cases. (setq jump-table (make-hash-table :test test :purecopy t :size (if (assq 'default cases) commit a12b416bca705c555ba049b18598533d3ae41ef2 Author: Vibhav Pant Date: Mon Feb 6 13:26:25 2017 +0530 ; byte(-opt, comp).el: Add more documentation for byte-switch code. diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el index 146fbcc1cb..888a5f8500 100644 --- a/lisp/emacs-lisp/byte-opt.el +++ b/lisp/emacs-lisp/byte-opt.el @@ -1773,6 +1773,9 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." ;; ((and (memq (car lap0) '(byte-goto byte-return)) (not (memq (car lap1) '(TAG nil))) + ;; FIXME: Instead of deferring simply when jump-tables are + ;; being used, keep a list of tags used for switch tags and + ;; use them instead (see `byte-compile-inline-lapcode'). (not byte-compile-jump-tables)) (setq tmp rest) (let ((i 0) diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 5aef82691c..c70e1bf5ed 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -3133,6 +3133,9 @@ for symbols generated by the byte compiler itself." ;; happens to be true for byte-code generated by bytecomp.el without ;; lexical-binding, but it's not true in general, and it's not true for ;; code output by bytecomp.el with lexical-binding. + ;; We also restore the value of `byte-compile-depth' and remove TAG depths + ;; accordingly when inlining byte-switch lap code, as documented in + ;; `byte-compile-cond-jump-table'. (let ((endtag (byte-compile-make-tag)) last-jump-tag ;; last TAG we have jumped to last-depth ;; last value of `byte-compile-depth' @@ -4061,6 +4064,22 @@ Return a list of the form ((TEST . VAR) ((VALUE BODY) ...))" (length cases))) default-tag (byte-compile-make-tag) donetag (byte-compile-make-tag)) + ;; The structure of byte-switch code: + ;; + ;; varref var + ;; constant #s(hash-table purecopy t data (val1 (TAG1) val2 (TAG2))) + ;; switch + ;; goto DEFAUT-TAG + ;; TAG1 + ;; + ;; goto DONETAG + ;; TAG2 + ;; + ;; goto DONETAG + ;; DEFAULT-TAG + ;; + ;; DONETAG + (byte-compile-variable-ref var) (byte-compile-push-constant jump-table) (byte-compile-out 'byte-switch) commit ad70ca1dad26da79f0a95cc0ec687902ef20fa9b Merge: 2db473bda8 148100d983 Author: Vibhav Pant Date: Sun Feb 5 23:08:53 2017 +0530 Merge remote-tracking branch 'origin/master' into feature/byte-switch commit 2db473bda8be72cf3c1e4694d70ce48f60492b0e Author: Vibhav Pant Date: Sun Feb 5 22:32:21 2017 +0530 bytecomp.el: Use macroexp-const-p instead of bc-cond-valid-obj2-p. * lisp/emacs-lisp/bytecomp.el (byte-compile-cond-vars): Use (macroexp-cons-p) instead of (byte-compile-cond-valid-obj2-p) to make sure that obj1/obj2 can be compared with `eq'. diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index bddf04af67..5aef82691c 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -4001,19 +4001,13 @@ that suppresses all warnings during execution of BODY." (byte-compile-out-tag donetag)))) (setq byte-compile--for-effect nil)) -(defun byte-compile-cond-valid-obj2-p (obj) - (cond - ((consp obj) - (and (eq (car obj) 'quote) - (= (length obj) 2) - (symbolp (cadr obj)))) - ((symbolp obj) (keywordp obj)) - (t t))) - (defun byte-compile-cond-vars (obj1 obj2) + ;; We make sure that of OBJ1 and OBJ2, one of them is a symbol, + ;; and the other is a constant expression whose value can be + ;; compared with `eq' (with `macroexp-const-p'). (or - (and (symbolp obj1) (byte-compile-cond-valid-obj2-p obj2) (cons obj1 obj2)) - (and (symbolp obj2) (byte-compile-cond-valid-obj2-p obj1) (cons obj2 obj1)))) + (and (symbolp obj1) (macroexp-const-p obj2) (cons obj1 obj2)) + (and (symbolp obj2) (macroexp-const-p obj1) (cons obj2 obj1)))) (defun byte-compile-cond-jump-table-info (clauses) "If CLAUSES is a `cond' form where: commit 74a3423b0b92b80d84f6de62d1f2d61c21e4bd90 Author: Vibhav Pant Date: Sun Feb 5 22:10:22 2017 +0530 * byte-opt.el (byte-decompile-bytecode-1): Use eq instead of =. diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el index edfa578f85..146fbcc1cb 100644 --- a/lisp/emacs-lisp/byte-opt.el +++ b/lisp/emacs-lisp/byte-opt.el @@ -1405,7 +1405,7 @@ ;; TAGs. (let ((orig-table last-constant)) (cl-loop for e across constvec - when (= e last-constant) + when (eq e last-constant) do (setq last-constant (copy-hash-table e)) and return nil) ;; Replace all addresses with TAGs. commit 382f6603ad4ba2a69b3961bdc68580ce77d222f9 Author: Vibhav Pant Date: Sun Feb 5 21:51:05 2017 +0530 ; Fix typo. * lisp/emacs-lisp/bytecomp.el (byte-compile-cond-jump-table-info): Fix typo in docstring. diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 7346dccdad..bddf04af67 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -4019,7 +4019,7 @@ that suppresses all warnings during execution of BODY." "If CLAUSES is a `cond' form where: The condition for each clause is of the form (TEST VAR VALUE). VAR is a variable. -TEST and VAR are the same throughtout all conditions. +TEST and VAR are the same throughout all conditions. VALUE is either a constant or a quoted form. Return a list of the form ((TEST . VAR) ((VALUE BODY) ...))" commit 490fc5a5029c0d8e527a0c7f423ba83fd6afda60 Author: Vibhav Pant Date: Sun Feb 5 21:48:27 2017 +0530 ; bytecomp.el (-inline-lapcode): Fix incorrect parenthesis, refactor diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 6e6c48399e..7346dccdad 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -3152,14 +3152,14 @@ for symbols generated by the byte compiler itself." last-jump-tag nil)) (byte-compile-out-tag op)) ((memq (car op) byte-goto-ops) - (setq last-depth byte-compile-depth) - (when last-switch (push (cdr op) switch-default-tags)) + (setq last-depth byte-compile-depth + last-jump-tag (cdr op)) (byte-compile-goto (car op) (cdr op)) (when last-switch + (push (cdr op) switch-default-tags) (setcdr (cdr (cdr op)) nil) (setq byte-compile-depth last-depth - last-switch nil)) - (setq last-jump-tag (cdr op))) + last-switch nil))) ((eq (car op) 'byte-return) (byte-compile-discard (- byte-compile-depth end-depth) t) (byte-compile-goto 'byte-goto endtag)) @@ -3172,7 +3172,7 @@ for symbols generated by the byte compiler itself." last-constant)) (setq last-constant (and (eq (car op) 'byte-constant) (cadr op))) (setq last-depth byte-compile-depth) - (byte-compile-out (car op)) (cdr op)))) + (byte-compile-out (car op) (cdr op))))) (byte-compile-out-tag endtag))) (defun byte-compile-unfold-bcf (form) commit cadb044fc2e69266308cdcabe6181be0f624b484 Author: Vibhav Pant Date: Sun Feb 5 19:23:53 2017 +0530 bytecomp.el: Inline lapcode containing `byte-switch' correctly. * lisp/emacs-lisp/bytecomp.el (byte-compile-inline-lapcode): Restore value of byte-compile-depth after emitting a jump to a tag in a jump table, or default/done tags. Set the depth of final tags for byte-switch to nil after emitting any jumps to them. diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index b7852c57eb..6e6c48399e 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -3133,15 +3133,46 @@ for symbols generated by the byte compiler itself." ;; happens to be true for byte-code generated by bytecomp.el without ;; lexical-binding, but it's not true in general, and it's not true for ;; code output by bytecomp.el with lexical-binding. - (let ((endtag (byte-compile-make-tag))) + (let ((endtag (byte-compile-make-tag)) + last-jump-tag ;; last TAG we have jumped to + last-depth ;; last value of `byte-compile-depth' + last-constant ;; value of the last constant encountered + last-switch ;; whether the last op encountered was byte-switch + switch-tags ;; a list of tags that byte-switch could jump to + ;; a list of tags byte-switch will jump to, if the value doesn't + ;; match any entry in the hash table + switch-default-tags) (dolist (op lap) (cond - ((eq (car op) 'TAG) (byte-compile-out-tag op)) - ((memq (car op) byte-goto-ops) (byte-compile-goto (car op) (cdr op))) + ((eq (car op) 'TAG) + (when (or (member op switch-tags) (member op switch-default-tags)) + (when last-jump-tag + (setcdr (cdr last-jump-tag) nil)) + (setq byte-compile-depth last-depth + last-jump-tag nil)) + (byte-compile-out-tag op)) + ((memq (car op) byte-goto-ops) + (setq last-depth byte-compile-depth) + (when last-switch (push (cdr op) switch-default-tags)) + (byte-compile-goto (car op) (cdr op)) + (when last-switch + (setcdr (cdr (cdr op)) nil) + (setq byte-compile-depth last-depth + last-switch nil)) + (setq last-jump-tag (cdr op))) ((eq (car op) 'byte-return) (byte-compile-discard (- byte-compile-depth end-depth) t) (byte-compile-goto 'byte-goto endtag)) - (t (byte-compile-out (car op) (cdr op))))) + (t + (when (eq (car op) 'byte-switch) + (push last-constant byte-compile-jump-tables) + (setq last-switch t) + (maphash #'(lambda (_k tag) + (push tag switch-tags)) + last-constant)) + (setq last-constant (and (eq (car op) 'byte-constant) (cadr op))) + (setq last-depth byte-compile-depth) + (byte-compile-out (car op)) (cdr op)))) (byte-compile-out-tag endtag))) (defun byte-compile-unfold-bcf (form) commit fea1ad36a0f7b1538984ab0f077095a53c570aa4 Author: Vibhav Pant Date: Sun Feb 5 18:55:45 2017 +0530 ; * byte-opt.el (byte-decompile-bytecode-1): Add more documentation. diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el index b962916e67..edfa578f85 100644 --- a/lisp/emacs-lisp/byte-opt.el +++ b/lisp/emacs-lisp/byte-opt.el @@ -1417,8 +1417,10 @@ (push (cons (+ (car tag) (lsh (cdr tag) 8)) newtag) tags) (puthash value newtag last-constant))) last-constant) + ;; Replace the hash table referenced in the lapcode with our + ;; modified one. (cl-loop for el in-ref lap - when (and (listp el) + when (and (listp el) ;; make sure we're at the correct op (eq (nth 1 el) 'byte-constant) (eq (nth 2 el) orig-table)) do (setf (nth 2 el) last-constant) and return nil)))) commit 84eef501554324b22c7a838aabed77aa79315121 Author: Vibhav Pant Date: Sun Feb 5 18:49:24 2017 +0530 byte-opt.el: Replace jump tables while decompiling correctly. * lisp/emacs-lisp/byte-opt.el (byte-decompile-bytecode-1): Don't make a copy of the constant vector, as it isn't used with the decompiled lapcode. Make sure that the correct lapcode pair/list is being modified while replacing the jump table. diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el index b775976efb..b962916e67 100644 --- a/lisp/emacs-lisp/byte-opt.el +++ b/lisp/emacs-lisp/byte-opt.el @@ -1400,23 +1400,28 @@ ((eq bytedecomp-op 'byte-switch) (cl-assert (hash-table-p last-constant) nil "byte-switch used without preceeding hash table") - ;; make a copy of constvec to avoid making changes to the - ;; original jump table for the compiled function. - (setq constvec (cl-map 'vector - #'(lambda (e) - (if (eq last-constant e) - (setq last-constant (copy-hash-table e)) - e)) - constvec)) - (maphash #'(lambda (value tag) - (let (newtag) - (cl-assert (consp tag) - nil "Invalid address for byte-switch") - (setq newtag (byte-compile-make-tag)) - (push (cons (+ (car tag) (lsh (cdr tag) 8)) newtag) tags) - (puthash value newtag last-constant))) - last-constant) - (setf (nth 2 (cadr lap)) last-constant))) + ;; We cannot use the original hash table referenced in the op, + ;; so we create a copy of it, and replace the addresses with + ;; TAGs. + (let ((orig-table last-constant)) + (cl-loop for e across constvec + when (= e last-constant) + do (setq last-constant (copy-hash-table e)) + and return nil) + ;; Replace all addresses with TAGs. + (maphash #'(lambda (value tag) + (let (newtag) + (cl-assert (consp tag) + nil "Invalid address for byte-switch") + (setq newtag (byte-compile-make-tag)) + (push (cons (+ (car tag) (lsh (cdr tag) 8)) newtag) tags) + (puthash value newtag last-constant))) + last-constant) + (cl-loop for el in-ref lap + when (and (listp el) + (eq (nth 1 el) 'byte-constant) + (eq (nth 2 el) orig-table)) + do (setf (nth 2 el) last-constant) and return nil)))) ;; lap = ( [ (pc . (op . arg)) ]* ) (push (cons optr (cons bytedecomp-op (or offset 0))) lap) commit 44c95c58b26b7b9d75965a83930ec3d77ffae28f Author: Vibhav Pant Date: Sun Feb 5 15:37:43 2017 +0530 bytecomp.el: Don't store non-keyword symbols in jump-tables. * lisp/emacs-lisp/bytecomp.el (byte-compile-cond-valid-obj2-p) return nil when OBJ is a non-keyword symbol (i.e a variable), as the jump table can only be used when comparing variables with constant values. diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 53622a47d7..b7852c57eb 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -3971,11 +3971,13 @@ that suppresses all warnings during execution of BODY." (setq byte-compile--for-effect nil)) (defun byte-compile-cond-valid-obj2-p (obj) - (if (consp obj) - (and (eq (car obj) 'quote) - (= (length obj) 2) - (symbolp (cadr obj))) - t)) + (cond + ((consp obj) + (and (eq (car obj) 'quote) + (= (length obj) 2) + (symbolp (cadr obj)))) + ((symbolp obj) (keywordp obj)) + (t t))) (defun byte-compile-cond-vars (obj1 obj2) (or commit de456d1e4a1d7e34be6d040e0d8a04c42b14e62e Author: Vibhav Pant Date: Fri Feb 3 23:23:28 2017 +0530 Revert "Use maphash instead of cl-loop." This reverts commit bfa88520136dd6b187ba101e6db5a5f8f0d5e874. diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index f0a6289e66..53622a47d7 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -917,10 +917,10 @@ CONST2 may be evaluated multiple times." (if (> (car bytes-tail) 255) (error "Bytecode overflow"))) (dolist (hash-table byte-compile-jump-tables) - (maphash #'(lambda (k tag) - (setq pc (car tag)) - (puthash k (cons (logand pc 255) (lsh pc -8)) hash-table)) - hash-table)) + (cl-loop for k being the hash-keys of hash-table do + (let ((tag (cdr (gethash k hash-table)))) + (setq pc (car tag)) + (puthash k (cons (logand pc 255) (lsh pc -8)) hash-table)))) (apply 'unibyte-string (nreverse bytes)))) commit bfa88520136dd6b187ba101e6db5a5f8f0d5e874 Author: Vibhav Pant Date: Wed Feb 1 18:15:59 2017 +0530 Use maphash instead of cl-loop. * lisp/emacs-lisp/bytecomp.el: (byte-compile-lapcode) Use maphash instead of cl-loop diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 53622a47d7..f0a6289e66 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -917,10 +917,10 @@ CONST2 may be evaluated multiple times." (if (> (car bytes-tail) 255) (error "Bytecode overflow"))) (dolist (hash-table byte-compile-jump-tables) - (cl-loop for k being the hash-keys of hash-table do - (let ((tag (cdr (gethash k hash-table)))) - (setq pc (car tag)) - (puthash k (cons (logand pc 255) (lsh pc -8)) hash-table)))) + (maphash #'(lambda (k tag) + (setq pc (car tag)) + (puthash k (cons (logand pc 255) (lsh pc -8)) hash-table)) + hash-table)) (apply 'unibyte-string (nreverse bytes)))) commit f441451658ecb8d0d8ba386d9fd3eebf3b17d549 Author: Vibhav Pant Date: Mon Jan 30 19:22:09 2017 +0530 * lisp/emacs-lisp/bytecomp.el: Create jump tables with :purecopy t diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index eb297288c6..53622a47d7 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -4028,6 +4028,7 @@ Return a list of the form ((TEST . VAR) ((VALUE BODY) ...))" jump-table test-obj body tag donetag default-tag default-case) (when (and cases (not (= (length cases) 1))) (setq jump-table (make-hash-table :test test + :purecopy t :size (if (assq 'default cases) (1- (length cases)) (length cases))) commit bf7f7c0d82a56ed1b76358657e74ca2833b19fe2 Merge: 25d38a06ec 9c4dfdd1af Author: Vibhav Pant Date: Mon Jan 30 18:35:43 2017 +0530 Merge remote-tracking branch 'origin/master' into feature/byte-switch commit 25d38a06eceb0853190a2d9acf53d85686f524bd Author: Vibhav Pant Date: Thu Jan 26 23:03:02 2017 +0530 * lisp/emacs-lisp/bytecomp.el:(bc-cond-jump-table-info)add docstring diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index b955e9919d..eb297288c6 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -3983,6 +3983,13 @@ that suppresses all warnings during execution of BODY." (and (symbolp obj2) (byte-compile-cond-valid-obj2-p obj1) (cons obj2 obj1)))) (defun byte-compile-cond-jump-table-info (clauses) + "If CLAUSES is a `cond' form where: +The condition for each clause is of the form (TEST VAR VALUE). +VAR is a variable. +TEST and VAR are the same throughtout all conditions. +VALUE is either a constant or a quoted form. + +Return a list of the form ((TEST . VAR) ((VALUE BODY) ...))" (let ((cases '()) (ok t) prev-var prev-test) commit a7e4870f165e9fd36d5cfcabb19b215b94373602 Author: Vibhav Pant Date: Thu Jan 26 14:31:16 2017 +0530 * lisp/emacs-lisp/bytecomp.el: Use correct function to push nil * lisp/emacs-lisp/bytecomp.el: (byte-compile-cond-jump-table) Use byte-compile-constant instead of byte-compile-form to push nil. diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index dff8bcfa20..b955e9919d 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -4067,7 +4067,7 @@ that suppresses all warnings during execution of BODY." (byte-compile-out-tag default-tag) (if default-case (byte-compile-body-do-effect default-case) - (byte-compile-form 'nil)) + (byte-compile-constant nil)) (byte-compile-out-tag donetag) (push jump-table byte-compile-jump-tables)))) commit 6a82d19db18f8480342cc4c1a0ad76c75df41941 Author: Vibhav Pant Date: Thu Jan 26 14:28:23 2017 +0530 * lisp/emacs-lisp/disass.el: Fix spacing while showing jump tables diff --git a/lisp/emacs-lisp/disass.el b/lisp/emacs-lisp/disass.el index 22c1c962a3..66673b4d26 100644 --- a/lisp/emacs-lisp/disass.el +++ b/lisp/emacs-lisp/disass.el @@ -224,10 +224,14 @@ OBJ should be a call to BYTE-CODE generated by the byte compiler." ;; if the succeeding op is byte-switch, display the jump table ;; used (cond ((eq (car-safe (car-safe (cdr lap))) 'byte-switch) - (insert (format "")) ;; if the value of the constant is compiled code, then ;; recursively disassemble it. commit 4e6140b28324a9a63d54084c920206d00aed094e Author: Vibhav Pant Date: Thu Jan 26 01:02:16 2017 +0530 * lisp/emacs-lisp/disass.el: Display jump tables for switch. diff --git a/lisp/emacs-lisp/disass.el b/lisp/emacs-lisp/disass.el index 97e45e070d..22c1c962a3 100644 --- a/lisp/emacs-lisp/disass.el +++ b/lisp/emacs-lisp/disass.el @@ -221,9 +221,17 @@ OBJ should be a call to BYTE-CODE generated by the byte compiler." ((memq op '(byte-constant byte-constant2)) ;; it's a constant (setq arg (car arg)) - ;; but if the value of the constant is compiled code, then - ;; recursively disassemble it. - (cond ((or (byte-code-function-p arg) + ;; if the succeeding op is byte-switch, display the jump table + ;; used + (cond ((eq (car-safe (car-safe (cdr lap))) 'byte-switch) + (insert (format "")) + ;; if the value of the constant is compiled code, then + ;; recursively disassemble it. + ((or (byte-code-function-p arg) (and (consp arg) (functionp arg) (assq 'byte-code arg)) (and (eq (car-safe arg) 'macro) commit 19cb3985a3795539b51d70625904e95a6e581eef Author: Vibhav Pant Date: Thu Jan 26 01:00:41 2017 +0530 * lisp/emacs-lisp/bytecomp.el:Use correct size for switch jump-table diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index b608844a08..dff8bcfa20 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -4020,7 +4020,10 @@ that suppresses all warnings during execution of BODY." (cases (cadr table-info)) jump-table test-obj body tag donetag default-tag default-case) (when (and cases (not (= (length cases) 1))) - (setq jump-table (make-hash-table :test test :size (length cases)) + (setq jump-table (make-hash-table :test test + :size (if (assq 'default cases) + (1- (length cases)) + (length cases))) default-tag (byte-compile-make-tag) donetag (byte-compile-make-tag)) (byte-compile-variable-ref var) commit c52a9b6ddd9166571e6bc8bb9426b0267874f9fa Author: Vibhav Pant Date: Thu Jan 26 00:58:36 2017 +0530 * lisp/emacs-lisp/bytecomp.el: Simplify b-c-cond-valid-obj2-p diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 0da1418321..b608844a08 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -3971,11 +3971,11 @@ that suppresses all warnings during execution of BODY." (setq byte-compile--for-effect nil)) (defun byte-compile-cond-valid-obj2-p (obj) - (cond - ((consp obj) (and (eq (car obj) 'quote) - (= (length obj) 2) - (symbolp (cadr obj)))) - (t t))) + (if (consp obj) + (and (eq (car obj) 'quote) + (= (length obj) 2) + (symbolp (cadr obj))) + t)) (defun byte-compile-cond-vars (obj1 obj2) (or commit 8189b97e5ca12aff8ea34617431a868010643b5b Author: Vibhav Pant Date: Thu Jan 26 00:57:10 2017 +0530 * lisp/emacs-lisp/bytecomp.el: Fix byte-switch codegen with symbols. diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 3c59c92c04..0da1418321 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -4005,7 +4005,7 @@ that suppresses all warnings during execution of BODY." (eq obj1 prev-var) ;; discard duplicate clauses (not (assq obj2 cases))) - (push (list (eval obj2) body) cases) + (push (list (if (consp obj2) (eval obj2) obj2) body) cases) (if (eq condition t) (progn (push (list 'default body) cases) (throw 'break t)) commit 0d3c57dcf3187864c0b6fd6115ee80ad33faf553 Author: Vibhav Pant Date: Thu Jan 26 00:54:59 2017 +0530 * lisp/emacs-lisp/byte-opt.el: Add support for decompiling switch * lisp/emacs-lisp/byte-opt.el: (byte-decompile-bytecode-1) When the constant encountered precedes a byte-switch op, replace all the addresses in the jump table with tags. diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el index c774d26c04..b775976efb 100644 --- a/lisp/emacs-lisp/byte-opt.el +++ b/lisp/emacs-lisp/byte-opt.el @@ -1357,7 +1357,7 @@ (defun byte-decompile-bytecode-1 (bytes constvec &optional make-spliceable) (let ((length (length bytes)) (bytedecomp-ptr 0) optr tags bytedecomp-op offset - lap tmp) + lap tmp last-constant) (while (not (= bytedecomp-ptr length)) (or make-spliceable (push bytedecomp-ptr lap)) @@ -1386,7 +1386,8 @@ (or (assq tmp byte-compile-variables) (let ((new (list tmp))) (push new byte-compile-variables) - new))))) + new))) + last-constant tmp)) ((eq bytedecomp-op 'byte-stack-set2) (setq bytedecomp-op 'byte-stack-set)) ((and (eq bytedecomp-op 'byte-discardN) (>= offset #x80)) @@ -1395,7 +1396,27 @@ ;; lapcode, we represent this by using a different opcode ;; (with the flag removed from the operand). (setq bytedecomp-op 'byte-discardN-preserve-tos) - (setq offset (- offset #x80)))) + (setq offset (- offset #x80))) + ((eq bytedecomp-op 'byte-switch) + (cl-assert (hash-table-p last-constant) nil + "byte-switch used without preceeding hash table") + ;; make a copy of constvec to avoid making changes to the + ;; original jump table for the compiled function. + (setq constvec (cl-map 'vector + #'(lambda (e) + (if (eq last-constant e) + (setq last-constant (copy-hash-table e)) + e)) + constvec)) + (maphash #'(lambda (value tag) + (let (newtag) + (cl-assert (consp tag) + nil "Invalid address for byte-switch") + (setq newtag (byte-compile-make-tag)) + (push (cons (+ (car tag) (lsh (cdr tag) 8)) newtag) tags) + (puthash value newtag last-constant))) + last-constant) + (setf (nth 2 (cadr lap)) last-constant))) ;; lap = ( [ (pc . (op . arg)) ]* ) (push (cons optr (cons bytedecomp-op (or offset 0))) lap) commit 23a130ee0d61fc39cee157921679809017a02b39 Author: Vibhav Pant Date: Sat Jan 21 11:37:20 2017 +0530 * lisp/emacs-lisp/bytecomp.el: Remove unused debugging statements. diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index cb235697ed..3c59c92c04 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -4083,11 +4083,9 @@ that suppresses all warnings during execution of BODY." clauses nil)) ((cdr clauses) (byte-compile-form (car clause)) - ;; (message "out %s" donetag) (if (null (cdr clause)) ;; First clause is a singleton. (byte-compile-goto-if t byte-compile--for-effect donetag) - ;; (message "inside %s" donetag) (setq nexttag (byte-compile-make-tag)) (byte-compile-goto 'byte-goto-if-nil nexttag) (byte-compile-maybe-guarded (car clause) commit fbe6b90b0ced594cf74d5fd0dc9a32666f0d7d38 Author: Vibhav Pant Date: Thu Jan 19 23:13:53 2017 +0530 * lisp/emacs-lisp/bytecomp.el: Fix errors with matching quoted forms * lisp/emacs-lisp/bytecomp.el: (byte-compile-cond-jump-table-info) eval obj2 to avoid quoted forms being stored as is. diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 74d135d155..cb235697ed 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -4005,7 +4005,7 @@ that suppresses all warnings during execution of BODY." (eq obj1 prev-var) ;; discard duplicate clauses (not (assq obj2 cases))) - (push (list obj2 body) cases) + (push (list (eval obj2) body) cases) (if (eq condition t) (progn (push (list 'default body) cases) (throw 'break t)) commit 5f3379b33866ff7dc16856b6c29712eae860af0e Author: Vibhav Pant Date: Thu Jan 19 23:13:13 2017 +0530 lisp/emacs-lisp/bytecomp.el: Use byte-switch only for quoted symbols diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index a4f1242ce4..74d135d155 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -3972,7 +3972,9 @@ that suppresses all warnings during execution of BODY." (defun byte-compile-cond-valid-obj2-p (obj) (cond - ((consp obj) (eq (car obj) 'quote)) + ((consp obj) (and (eq (car obj) 'quote) + (= (length obj) 2) + (symbolp (cadr obj)))) (t t))) (defun byte-compile-cond-vars (obj1 obj2) commit 46193d5209780d21b848374d8c377fb6c8896d1b Author: Vibhav Pant Date: Thu Jan 19 23:12:09 2017 +0530 * lisp/emacs-lisp/bytecomp.el: Add default-case for last cond clause. * lisp/emacs-lisp/bytecomp.el: (byte-compile-cond-jump-table) Add default-case for last cond clause. diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 2c10d01ddc..a4f1242ce4 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -4019,23 +4019,24 @@ that suppresses all warnings during execution of BODY." jump-table test-obj body tag donetag default-tag default-case) (when (and cases (not (= (length cases) 1))) (setq jump-table (make-hash-table :test test :size (length cases)) + default-tag (byte-compile-make-tag) donetag (byte-compile-make-tag)) (byte-compile-variable-ref var) (byte-compile-push-constant jump-table) (byte-compile-out 'byte-switch) + ;; When the opcode argument is `byte-goto', `byte-compile-goto' sets + ;; `byte-compile-depth' to `nil'. However, we need `byte-compile-depth' + ;; to be non-nil for generating tags for all cases. Since + ;; `byte-compile-depth' will increase by atmost 1 after compiling + ;; all of the clause (which is further enforced by cl-assert below) + ;; it should be safe to preserve it's value. + (let ((byte-compile-depth byte-compile-depth)) + (byte-compile-goto 'byte-goto default-tag)) + (when (assq 'default cases) (setq default-case (cadr (assq 'default cases)) - default-tag (byte-compile-make-tag)) - (setq cases (butlast cases 1)) - ;; When the opcode argument is `byte-goto', `byte-compile-goto' sets - ;; `byte-compile-depth' to `nil'. However, we need `byte-compile-depth' - ;; to be non-nil for generating tags for all cases. Since - ;; `byte-compile-depth' will increase by atmost 1 after compiling - ;; all of the clause (which is further enforced by cl-assert below) - ;; it should be safe to preserve it's value. - (let ((byte-compile-depth byte-compile-depth)) - (byte-compile-goto 'byte-goto default-tag))) + cases (butlast cases 1))) (dolist (case cases) (setq tag (byte-compile-make-tag) @@ -4051,21 +4052,23 @@ that suppresses all warnings during execution of BODY." ;; increase by one for every clause body compiled, causing ;; depth/tag conflicts or violating asserts down the road. ;; To make sure `byte-compile-body' itself doesn't violate this, - ;; we use `cl-assert' (which probably doesn't need to . + ;; we use `cl-assert'. (byte-compile-body body byte-compile--for-effect) (cl-assert (or (= byte-compile-depth init-depth) (= byte-compile-depth (1+ init-depth)))) - (byte-compile-goto 'byte-goto donetag))) + (byte-compile-goto 'byte-goto donetag) + (setcdr (cdr donetag) nil))) + (byte-compile-out-tag default-tag) (if default-case - (progn (byte-compile-out-tag default-tag) - (byte-compile-body-do-effect default-case)) - (byte-compile-push-constant nil)) + (byte-compile-body-do-effect default-case) + (byte-compile-form 'nil)) (byte-compile-out-tag donetag) (push jump-table byte-compile-jump-tables)))) (defun byte-compile-cond (clauses) - (or (and byte-compile-cond-use-jump-table (byte-compile-cond-jump-table clauses)) + (or (and byte-compile-cond-use-jump-table + (byte-compile-cond-jump-table clauses)) (let ((donetag (byte-compile-make-tag)) nexttag clause) (while (setq clauses (cdr clauses)) commit 522f16dac945eee351cefb066af40f0d1a683f38 Author: Vibhav Pant Date: Thu Jan 19 18:35:46 2017 +0530 Add type checking for Bswitch, when enabled at compile time. * src/bytecode.c: (exec_byte_code) If BYTE_CODE_SAFE is enabled at compile time, use CHECK_TYPE to verify that the jump table is a hash table. diff --git a/src/bytecode.c b/src/bytecode.c index fc434a2812..f4540e94c9 100644 --- a/src/bytecode.c +++ b/src/bytecode.c @@ -1417,6 +1417,9 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, { Lisp_Object jmp_table = POP; Lisp_Object v1 = POP; +#ifdef BYTE_CODE_SAFE + CHECK_TYPE (HASH_TABLE_P (jmp_table), Qhash_table_p, jmp_table); +#endif struct Lisp_Hash_Table *h = XHASH_TABLE(jmp_table); ptrdiff_t i = hash_lookup(h, v1, NULL); if (i >= 0) { commit 1fcbd352f8116aca1ecdb62e84f3d86b89bc446f Author: Vibhav Pant Date: Thu Jan 19 18:02:40 2017 +0530 Use byte-switch for all symbols. * lisp/emacs-lisp/bytecomp.el: (byte-compile-cond-valid-obj2-p) Return t for all symbols (instead for just keywords) diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 2bc469b17f..2c10d01ddc 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -3972,7 +3972,6 @@ that suppresses all warnings during execution of BODY." (defun byte-compile-cond-valid-obj2-p (obj) (cond - ((symbolp obj) (keywordp obj)) ((consp obj) (eq (car obj) 'quote)) (t t))) commit 086c4eaf9d4ecc5074088115fa01c0b2fb061246 Author: Vibhav Pant Date: Wed Jan 18 22:40:50 2017 +0530 * src/bytecode.c: (exec_byte_code) Use hash_lookup for Bswitch Fgethash type checks the provided table object, which is unnecessary for compiled bytecode. diff --git a/src/bytecode.c b/src/bytecode.c index 1695af9cb0..fc434a2812 100644 --- a/src/bytecode.c +++ b/src/bytecode.c @@ -1417,8 +1417,10 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, { Lisp_Object jmp_table = POP; Lisp_Object v1 = POP; - Lisp_Object dest = Fgethash(v1, jmp_table, Qnil); - if (!NILP(dest)) { + struct Lisp_Hash_Table *h = XHASH_TABLE(jmp_table); + ptrdiff_t i = hash_lookup(h, v1, NULL); + if (i >= 0) { + Lisp_Object dest = HASH_VALUE(h, i); int car = XINT(XCAR(dest)); int cdr = XINT(XCDR(dest)); op = car + (cdr << 8); /* Simulate FETCH2 */ commit 37956463d67795819fe7d8fe02d6249388364783 Merge: 309b46420e fd6b829d91 Author: Vibhav Pant Date: Mon Jan 16 19:49:24 2017 +0530 update branch commit 309b46420e83826ed1e0b947f98a47e8525e3c36 Author: Vibhav Pant Date: Sun Jan 15 21:38:31 2017 +0530 * lisp/emacs-lisp/byte-opt.el: Optimize how tags are checked for use. * byte-opt.el: (byte-optimize-lapcode): Return nil instantly on finding the tag in a jump table. diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el index 9412ce3b26..c774d26c04 100644 --- a/lisp/emacs-lisp/byte-opt.el +++ b/lisp/emacs-lisp/byte-opt.el @@ -1730,10 +1730,9 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." ;; ((and (eq 'TAG (car lap0)) (not (rassq lap0 lap)) - (= (length (cl-loop for table in byte-compile-jump-tables - when (member lap0 (hash-table-values table)) - collect t)) - 0)) + (cl-loop for table in byte-compile-jump-tables + when (member lap0 (hash-table-values table)) + return nil finally return t)) (and (memq byte-optimize-log '(t byte)) (byte-compile-log " unused tag %d removed" (nth 1 lap0))) (setq lap (delq lap0 lap) commit 8c0f326ea237e8acd03c51c1b3a44d237c044562 Author: Vibhav Pant Date: Sun Jan 15 19:36:26 2017 +0530 * lisp/emacs-lisp/bytecomp.el: Add documentation, remove code duplication diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index fe91fecd35..2bc469b17f 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -754,7 +754,9 @@ otherwise pop it") ;; `byte-compile-lapcode'). (defconst byte-discardN-preserve-tos byte-discardN) -(byte-defop 183 -2 byte-switch) +(byte-defop 183 -2 byte-switch + "to take a hash table and a value from the stack, and jump to the address +the value maps to, if any.") ;; unused: 182-191 @@ -3999,7 +4001,9 @@ that suppresses all warnings during execution of BODY." (if (and obj1 (memq test '(eq eql equal)) (consp condition) (eq test prev-test) - (eq obj1 prev-var)) + (eq obj1 prev-var) + ;; discard duplicate clauses + (not (assq obj2 cases))) (push (list obj2 body) cases) (if (eq condition t) (progn (push (list 'default body) cases) @@ -4008,16 +4012,12 @@ that suppresses all warnings during execution of BODY." (throw 'break nil)))))) (list (cons prev-test prev-var) (nreverse cases))))) -(defun byte-compile-jump-table-add-tag (value tag jump-table) - (setcdr (cdr tag) byte-compile-depth) - (puthash value tag jump-table)) - (defun byte-compile-cond-jump-table (clauses) (let* ((table-info (byte-compile-cond-jump-table-info clauses)) (test (caar table-info)) (var (cdar table-info)) (cases (cadr table-info)) - jump-table test-obj body tag donetag finaltag finalcase) + jump-table test-obj body tag donetag default-tag default-case) (when (and cases (not (= (length cases) 1))) (setq jump-table (make-hash-table :test test :size (length cases)) donetag (byte-compile-make-tag)) @@ -4026,28 +4026,41 @@ that suppresses all warnings during execution of BODY." (byte-compile-out 'byte-switch) (when (assq 'default cases) - (setq finalcase (cadr (assq 'default cases)) - finaltag (byte-compile-make-tag)) + (setq default-case (cadr (assq 'default cases)) + default-tag (byte-compile-make-tag)) (setq cases (butlast cases 1)) + ;; When the opcode argument is `byte-goto', `byte-compile-goto' sets + ;; `byte-compile-depth' to `nil'. However, we need `byte-compile-depth' + ;; to be non-nil for generating tags for all cases. Since + ;; `byte-compile-depth' will increase by atmost 1 after compiling + ;; all of the clause (which is further enforced by cl-assert below) + ;; it should be safe to preserve it's value. (let ((byte-compile-depth byte-compile-depth)) - (byte-compile-goto 'byte-goto finaltag))) + (byte-compile-goto 'byte-goto default-tag))) (dolist (case cases) (setq tag (byte-compile-make-tag) test-obj (nth 0 case) body (nth 1 case)) (byte-compile-out-tag tag) - (byte-compile-jump-table-add-tag test-obj tag jump-table) - - (let ((byte-compile-depth byte-compile-depth)) - (byte-compile-maybe-guarded `(,test ,var ,test-obj) - (byte-compile-body body byte-compile--for-effect)) - (byte-compile-goto 'byte-goto donetag)) - (setcdr (cdr donetag) nil)) - - (if finalcase - (progn (byte-compile-out-tag finaltag) - (byte-compile-body-do-effect finalcase)) + (puthash test-obj tag jump-table) + + (let ((byte-compile-depth byte-compile-depth) + (init-depth byte-compile-depth)) + ;; Since `byte-compile-body' might increase `byte-compile-depth' + ;; by 1, not preserving it's value will cause it to potentially + ;; increase by one for every clause body compiled, causing + ;; depth/tag conflicts or violating asserts down the road. + ;; To make sure `byte-compile-body' itself doesn't violate this, + ;; we use `cl-assert' (which probably doesn't need to . + (byte-compile-body body byte-compile--for-effect) + (cl-assert (or (= byte-compile-depth init-depth) + (= byte-compile-depth (1+ init-depth)))) + (byte-compile-goto 'byte-goto donetag))) + + (if default-case + (progn (byte-compile-out-tag default-tag) + (byte-compile-body-do-effect default-case)) (byte-compile-push-constant nil)) (byte-compile-out-tag donetag) (push jump-table byte-compile-jump-tables)))) commit 88549ec38e9bb30e338a9985d0de4e6263b40fb7 Author: Vibhav Pant Date: Sun Jan 15 01:26:04 2017 +0530 Add new 'switch' byte-code. 'switch' takes two arguments from the stack: the variable to test, and a jump table (implemented as a hash-table with the appropriate :test function). By looking up the value of the variable in the hash table, the interpreter can jump to the label pointed to by the value, if any. This implementation can only be used for `cond' forms of the type `(cond ((test x 'foo) 'bar) ...)`, such that the function `test` and variable `x` is same for all clauses. * lisp/emacs-lisp/bytecomp.el: * Add (byte-compile-cond-valid-obj2-p), (byte-compile-cond-vars), (byte-compile-cond-jump-table-info), (byte-compile-jump-table-add-tag), (byte-compile-cond-jump-table), byte-compile-jump-tables. * Add defcustom `byte-compile-cond-use-jump-table'. * (byte-compile-cond): Use them. * (byte-compile-lapcode): Patch tags present in jump tables, if any. * lisp/emacs-lisp//byte-opt.el: (byte-optimize-lapcode): Add checks to some peephole optimizations to prevent them from messing up any code involving `byte-switch`. * src/bytecode.c: (exec_byte_code): Add bytecode Bswitch. diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el index 13f885448a..9412ce3b26 100644 --- a/lisp/emacs-lisp/byte-opt.el +++ b/lisp/emacs-lisp/byte-opt.el @@ -185,6 +185,7 @@ (require 'bytecomp) (eval-when-compile (require 'cl-lib)) (require 'macroexp) +(require 'subr-x) (defun byte-compile-log-lap-1 (format &rest args) ;; Newer byte codes for stack-ref make the slot 0 non-nil again. @@ -1728,7 +1729,11 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." ;; unused-TAG: --> ;; ((and (eq 'TAG (car lap0)) - (not (rassq lap0 lap))) + (not (rassq lap0 lap)) + (= (length (cl-loop for table in byte-compile-jump-tables + when (member lap0 (hash-table-values table)) + collect t)) + 0)) (and (memq byte-optimize-log '(t byte)) (byte-compile-log " unused tag %d removed" (nth 1 lap0))) (setq lap (delq lap0 lap) @@ -1736,9 +1741,12 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." ;; ;; goto ... --> goto ;; return ... --> return - ;; + ;; (unless a jump-table is being used, where deleting may affect + ;; other valid case bodies) + ;; ((and (memq (car lap0) '(byte-goto byte-return)) - (not (memq (car lap1) '(TAG nil)))) + (not (memq (car lap1) '(TAG nil))) + (not byte-compile-jump-tables)) (setq tmp rest) (let ((i 0) (opt-p (memq byte-optimize-log '(t lap))) diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 63be7e208b..fe91fecd35 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -223,6 +223,11 @@ This includes variable references and calls to functions such as `car'." :group 'bytecomp :type 'boolean) +(defcustom byte-compile-cond-use-jump-table t + "Compile `cond' clauses to a jump table implementation (using a hash-table)." + :group 'bytecomp + :type 'boolean) + (defvar byte-compile-dynamic nil "If non-nil, compile function bodies so they load lazily. They are hidden in comments in the compiled file, @@ -412,6 +417,8 @@ specify different fields to sort on." (const calls+callers) (const nil))) (defvar byte-compile-debug nil) +(defvar byte-compile-jump-tables nil + "List of all jump tables used during compilation of this form.") (defvar byte-compile-constants nil "List of all constants encountered during compilation of this form.") (defvar byte-compile-variables nil @@ -747,6 +754,8 @@ otherwise pop it") ;; `byte-compile-lapcode'). (defconst byte-discardN-preserve-tos byte-discardN) +(byte-defop 183 -2 byte-switch) + ;; unused: 182-191 (byte-defop 192 1 byte-constant "for reference to a constant") @@ -823,7 +832,7 @@ CONST2 may be evaluated multiple times." op off ; Operation & offset opcode ; numeric value of OP (bytes '()) ; Put the output bytes here - (patchlist nil)) ; List of gotos to patch + (patchlist nil)) ; List of gotos to patch (dolist (lap-entry lap) (setq op (car lap-entry) off (cdr lap-entry)) @@ -905,6 +914,11 @@ CONST2 may be evaluated multiple times." ;; FIXME: Replace this by some workaround. (if (> (car bytes-tail) 255) (error "Bytecode overflow"))) + (dolist (hash-table byte-compile-jump-tables) + (cl-loop for k being the hash-keys of hash-table do + (let ((tag (cdr (gethash k hash-table)))) + (setq pc (car tag)) + (puthash k (cons (logand pc 255) (lsh pc -8)) hash-table)))) (apply 'unibyte-string (nreverse bytes)))) @@ -1954,7 +1968,8 @@ With argument ARG, insert value in current buffer after the form." ;; (edebug-all-defs nil) ;; (edebug-all-forms nil) ;; Simulate entry to byte-compile-top-level - (byte-compile-constants nil) + (byte-compile-jump-tables nil) + (byte-compile-constants nil) (byte-compile-variables nil) (byte-compile-tag-number 0) (byte-compile-depth 0) @@ -2250,7 +2265,8 @@ list that represents a doc string reference. byte-compile-variables nil byte-compile-depth 0 byte-compile-maxdepth 0 - byte-compile-output nil)))) + byte-compile-output nil + byte-compile-jump-tables nil)))) (defvar byte-compile-force-lexical-warnings nil) @@ -2862,7 +2878,8 @@ for symbols generated by the byte compiler itself." (byte-compile-maxdepth 0) (byte-compile--lexical-environment lexenv) (byte-compile-reserved-constants (or reserved-csts 0)) - (byte-compile-output nil)) + (byte-compile-output nil) + (byte-compile-jump-tables nil)) (if (memq byte-optimize '(t source)) (setq form (byte-optimize-form form byte-compile--for-effect))) (while (and (eq (car-safe form) 'progn) (null (cdr (cdr form)))) @@ -3951,37 +3968,124 @@ that suppresses all warnings during execution of BODY." (byte-compile-out-tag donetag)))) (setq byte-compile--for-effect nil)) +(defun byte-compile-cond-valid-obj2-p (obj) + (cond + ((symbolp obj) (keywordp obj)) + ((consp obj) (eq (car obj) 'quote)) + (t t))) + +(defun byte-compile-cond-vars (obj1 obj2) + (or + (and (symbolp obj1) (byte-compile-cond-valid-obj2-p obj2) (cons obj1 obj2)) + (and (symbolp obj2) (byte-compile-cond-valid-obj2-p obj1) (cons obj2 obj1)))) + +(defun byte-compile-cond-jump-table-info (clauses) + (let ((cases '()) + (ok t) + prev-var prev-test) + (and (catch 'break + (dolist (clause (cdr clauses) ok) + (let* ((condition (car clause)) + (test (car-safe condition)) + (vars (when (consp condition) + (byte-compile-cond-vars (cadr condition) (cl-caddr condition)))) + (obj1 (car-safe vars)) + (obj2 (cdr-safe vars)) + (body (cdr-safe clause))) + (unless prev-var + (setq prev-var obj1)) + (unless prev-test + (setq prev-test test)) + (if (and obj1 (memq test '(eq eql equal)) + (consp condition) + (eq test prev-test) + (eq obj1 prev-var)) + (push (list obj2 body) cases) + (if (eq condition t) + (progn (push (list 'default body) cases) + (throw 'break t)) + (setq ok nil) + (throw 'break nil)))))) + (list (cons prev-test prev-var) (nreverse cases))))) + +(defun byte-compile-jump-table-add-tag (value tag jump-table) + (setcdr (cdr tag) byte-compile-depth) + (puthash value tag jump-table)) + +(defun byte-compile-cond-jump-table (clauses) + (let* ((table-info (byte-compile-cond-jump-table-info clauses)) + (test (caar table-info)) + (var (cdar table-info)) + (cases (cadr table-info)) + jump-table test-obj body tag donetag finaltag finalcase) + (when (and cases (not (= (length cases) 1))) + (setq jump-table (make-hash-table :test test :size (length cases)) + donetag (byte-compile-make-tag)) + (byte-compile-variable-ref var) + (byte-compile-push-constant jump-table) + (byte-compile-out 'byte-switch) + + (when (assq 'default cases) + (setq finalcase (cadr (assq 'default cases)) + finaltag (byte-compile-make-tag)) + (setq cases (butlast cases 1)) + (let ((byte-compile-depth byte-compile-depth)) + (byte-compile-goto 'byte-goto finaltag))) + + (dolist (case cases) + (setq tag (byte-compile-make-tag) + test-obj (nth 0 case) + body (nth 1 case)) + (byte-compile-out-tag tag) + (byte-compile-jump-table-add-tag test-obj tag jump-table) + + (let ((byte-compile-depth byte-compile-depth)) + (byte-compile-maybe-guarded `(,test ,var ,test-obj) + (byte-compile-body body byte-compile--for-effect)) + (byte-compile-goto 'byte-goto donetag)) + (setcdr (cdr donetag) nil)) + + (if finalcase + (progn (byte-compile-out-tag finaltag) + (byte-compile-body-do-effect finalcase)) + (byte-compile-push-constant nil)) + (byte-compile-out-tag donetag) + (push jump-table byte-compile-jump-tables)))) + (defun byte-compile-cond (clauses) - (let ((donetag (byte-compile-make-tag)) - nexttag clause) - (while (setq clauses (cdr clauses)) - (setq clause (car clauses)) - (cond ((or (eq (car clause) t) - (and (eq (car-safe (car clause)) 'quote) - (car-safe (cdr-safe (car clause))))) - ;; Unconditional clause - (setq clause (cons t clause) - clauses nil)) - ((cdr clauses) - (byte-compile-form (car clause)) - (if (null (cdr clause)) - ;; First clause is a singleton. - (byte-compile-goto-if t byte-compile--for-effect donetag) - (setq nexttag (byte-compile-make-tag)) - (byte-compile-goto 'byte-goto-if-nil nexttag) - (byte-compile-maybe-guarded (car clause) - (byte-compile-body (cdr clause) byte-compile--for-effect)) - (byte-compile-goto 'byte-goto donetag) - (byte-compile-out-tag nexttag))))) - ;; Last clause - (let ((guard (car clause))) - (and (cdr clause) (not (eq guard t)) - (progn (byte-compile-form guard) - (byte-compile-goto-if nil byte-compile--for-effect donetag) - (setq clause (cdr clause)))) - (byte-compile-maybe-guarded guard - (byte-compile-body-do-effect clause))) - (byte-compile-out-tag donetag))) + (or (and byte-compile-cond-use-jump-table (byte-compile-cond-jump-table clauses)) + (let ((donetag (byte-compile-make-tag)) + nexttag clause) + (while (setq clauses (cdr clauses)) + (setq clause (car clauses)) + (cond ((or (eq (car clause) t) + (and (eq (car-safe (car clause)) 'quote) + (car-safe (cdr-safe (car clause))))) + ;; Unconditional clause + (setq clause (cons t clause) + clauses nil)) + ((cdr clauses) + (byte-compile-form (car clause)) + ;; (message "out %s" donetag) + (if (null (cdr clause)) + ;; First clause is a singleton. + (byte-compile-goto-if t byte-compile--for-effect donetag) + ;; (message "inside %s" donetag) + (setq nexttag (byte-compile-make-tag)) + (byte-compile-goto 'byte-goto-if-nil nexttag) + (byte-compile-maybe-guarded (car clause) + (byte-compile-body (cdr clause) byte-compile--for-effect)) + (byte-compile-goto 'byte-goto donetag) + (byte-compile-out-tag nexttag))))) + ;; Last clause + (let ((guard (car clause))) + (and (cdr clause) (not (eq guard t)) + (progn (byte-compile-form guard) + (byte-compile-goto-if nil byte-compile--for-effect donetag) + (setq clause (cdr clause)))) + (byte-compile-maybe-guarded guard + (byte-compile-body-do-effect clause))) + (byte-compile-out-tag donetag)))) (defun byte-compile-and (form) (let ((failtag (byte-compile-make-tag)) @@ -4528,7 +4632,7 @@ binding slots have been popped." (and byte-compile-depth (not (= (cdr (cdr tag)) byte-compile-depth)) (error "Compiler bug: depth conflict at tag %d" (car (cdr tag)))) - (setq byte-compile-depth (cdr (cdr tag)))) + (setq byte-compile-depth (cdr (cdr tag)))) (setcdr (cdr tag) byte-compile-depth))) (defun byte-compile-goto (opcode tag) diff --git a/src/bytecode.c b/src/bytecode.c index a64bc171d1..1695af9cb0 100644 --- a/src/bytecode.c +++ b/src/bytecode.c @@ -267,6 +267,8 @@ DEFINE (Bstack_set, 0262) \ DEFINE (Bstack_set2, 0263) \ DEFINE (BdiscardN, 0266) \ \ +DEFINE (Bswitch, 0267) \ + \ DEFINE (Bconstant, 0300) enum byte_code_op @@ -1411,6 +1413,20 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, DISCARD (op); NEXT; + CASE (Bswitch): + { + Lisp_Object jmp_table = POP; + Lisp_Object v1 = POP; + Lisp_Object dest = Fgethash(v1, jmp_table, Qnil); + if (!NILP(dest)) { + int car = XINT(XCAR(dest)); + int cdr = XINT(XCDR(dest)); + op = car + (cdr << 8); /* Simulate FETCH2 */ + goto op_branch; + } + } + NEXT; + CASE_DEFAULT CASE (Bconstant): if (BYTE_CODE_SAFE