Mercurial > hg > xemacs-beta
comparison lisp/byte-optimize.el @ 5652:cc6f0266bc36
Avoid #'delq in core Lisp, for the sake of style, a very slightly smaller binary
lisp/ChangeLog addition:
2012-05-01 Aidan Kehoe <kehoea@parhasard.net>
Avoid #'delq in core code, for the sake of style and a (very
slightly) smaller binary.
* behavior.el (disable-behavior):
* behavior.el (compute-behavior-group-children):
* buff-menu.el (buffers-tab-items):
* byte-optimize.el (byte-optimize-delay-constants-math):
* byte-optimize.el (byte-optimize-logmumble):
* byte-optimize.el (byte-decompile-bytecode-1):
* byte-optimize.el (byte-optimize-lapcode):
* bytecomp.el:
* bytecomp.el (byte-compile-arglist-warn):
* bytecomp.el (byte-compile-warn-about-unresolved-functions):
* bytecomp.el (byte-compile-lambda):
* bytecomp.el (byte-compile-out-toplevel):
* bytecomp.el (byte-compile-insert):
* bytecomp.el (byte-compile-defalias-warn):
* cl-macs.el (cl-upcase-arg):
* cl-macs.el (cl-transform-lambda):
* cl-macs.el (cl-do-proclaim):
* cl-macs.el (defstruct):
* cl-macs.el (cl-make-type-test):
* cl-macs.el (define-compiler-macro):
* cl-macs.el (delete-duplicates):
* cus-edit.el (widget-face-value-delete):
* cus-edit.el (face-history):
* easymenu.el (easy-menu-remove):
* files.el (files-fetch-hook-value):
* files.el (file-expand-wildcards):
* font-lock.el (font-lock-update-removed-keyword-alist):
* font-lock.el (font-lock-remove-keywords):
* frame.el (frame-initialize):
* frame.el (frame-notice-user-settings):
* frame.el (set-frame-font):
* frame.el (delete-other-frames):
* frame.el (get-frame-for-buffer-noselect):
* gnuserv.el (gnuserv-kill-buffer-function):
* gnuserv.el (gnuserv-check-device):
* gnuserv.el (gnuserv-kill-client):
* gnuserv.el (gnuserv-buffer-done-1):
* gtk-font-menu.el (gtk-reset-device-font-menus):
* gutter-items.el (buffers-tab-items):
* gutter.el (set-gutter-element-visible-p):
* info.el (Info-find-file-node):
* info.el (Info-history-add):
* info.el (Info-build-annotation-completions):
* info.el (Info-index):
* info.el (Info-reannotate-node):
* itimer.el (delete-itimer):
* itimer.el (start-itimer):
* lib-complete.el (lib-complete:cache-completions):
* loadhist.el (unload-feature):
* menubar-items.el (build-buffers-menu-internal):
* menubar.el (delete-menu-item):
* menubar.el (relabel-menu-item):
* msw-font-menu.el (mswindows-reset-device-font-menus):
* mule/make-coding-system.el (fixed-width-generate-helper):
* next-error.el (next-error-find-buffer):
* obsolete.el:
* obsolete.el (find-non-ascii-charset-string):
* obsolete.el (find-non-ascii-charset-region):
* occur.el (multi-occur-by-filename-regexp):
* occur.el (occur-1):
* packages.el (packages-package-hierarchy-directory-names):
* packages.el (package-get-key-1):
* process.el (setenv):
* simple.el (undo):
* simple.el (handle-pre-motion-command-current-command-is-motion):
* sound.el (load-sound-file):
* wid-edit.el (widget-field-value-delete):
* wid-edit.el (widget-checklist-match-inline):
* wid-edit.el (widget-checklist-match-find):
* wid-edit.el (widget-editable-list-delete-at):
* wid-edit.el (widget-editable-list-entry-create):
* window.el (quit-window):
* x-font-menu.el (x-reset-device-font-menus-core):
1. Replace (delq nil (mapcar ....)) with analogous (mapcan ...)
forms; this is in non-dumped files, it was done previously in
dumped files.
2. Replace (delq FOO (copy-sequence BAR)) with (remove* FOO BAR),
where #'eq and #'eql are equivalent
3. Replace (delq FOO BAR) with (delete* FOO BAR), where FOO is not
a non-fixnum number. Saves a little space in the dumped file
(since the compiler macro adds :test #'eq to the delete* call if
it's not clear that FOO is not a non-fixnum number).
author | Aidan Kehoe <kehoea@parhasard.net> |
---|---|
date | Tue, 01 May 2012 16:17:42 +0100 |
parents | ae2fdb1fd9e0 |
children | e9c3fe82127d |
comparison
equal
deleted
inserted
replaced
5651:ae2fdb1fd9e0 | 5652:cc6f0266bc36 |
---|---|
708 ;; of doing it on integers. | 708 ;; of doing it on integers. |
709 (not (byte-optimize-approx-equal | 709 (not (byte-optimize-approx-equal |
710 (apply fun (mapcar 'float constants)) | 710 (apply fun (mapcar 'float constants)) |
711 (float (apply fun constants))))) | 711 (float (apply fun constants))))) |
712 (setq form orig) | 712 (setq form orig) |
713 (setq form (nconc (delq nil form) | 713 (setq form (nconc (delete* nil form) |
714 (list (apply fun (nreverse constants))))))))) | 714 (list (apply fun (nreverse constants))))))))) |
715 form)) | 715 form)) |
716 | 716 |
717 ;; END SYNC WITH 20.7. | 717 ;; END SYNC WITH 20.7. |
718 | 718 |
785 (setq form (byte-optimize-delay-constants-math form 1 (car form))) | 785 (setq form (byte-optimize-delay-constants-math form 1 (car form))) |
786 (byte-optimize-predicate | 786 (byte-optimize-predicate |
787 (cond ((memq 0 form) | 787 (cond ((memq 0 form) |
788 (setq form (if (eq (car form) 'logand) | 788 (setq form (if (eq (car form) 'logand) |
789 (cons 'progn (cdr form)) | 789 (cons 'progn (cdr form)) |
790 (delq 0 (copy-sequence form))))) | 790 (remove* 0 form)))) |
791 ((and (eq (car-safe form) 'logior) | 791 ((and (eq (car-safe form) 'logior) |
792 (memq -1 form)) | 792 (memq -1 form)) |
793 (cons 'progn (cdr form))) | 793 (cons 'progn (cdr form))) |
794 (form)))) | 794 (form)))) |
795 | 795 |
1460 (cond ((numberp (car rest))) | 1460 (cond ((numberp (car rest))) |
1461 ((setq tmp (assq (car (car rest)) tags)) | 1461 ((setq tmp (assq (car (car rest)) tags)) |
1462 ;; this addr is jumped to | 1462 ;; this addr is jumped to |
1463 (setcdr rest (cons (cons nil (cdr tmp)) | 1463 (setcdr rest (cons (cons nil (cdr tmp)) |
1464 (cdr rest))) | 1464 (cdr rest))) |
1465 (setq tags (delq tmp tags)) | 1465 (setq tags (delete* tmp tags)) |
1466 (setq rest (cdr rest)))) | 1466 (setq rest (cdr rest)))) |
1467 (setq rest (cdr rest)))) | 1467 (setq rest (cdr rest)))) |
1468 (if tags (error "optimizer error: missed tags %s" tags)) | 1468 (if tags (error "optimizer error: missed tags %s" tags)) |
1469 (if (null (car (cdr (car lap)))) | 1469 (if (null (car (cdr (car lap)))) |
1470 (setq lap (cdr lap))) | 1470 (setq lap (cdr lap))) |
1589 (setq tmp (aref byte-stack+-info (symbol-value (car lap0)))) | 1589 (setq tmp (aref byte-stack+-info (symbol-value (car lap0)))) |
1590 (setq rest (cdr rest)) | 1590 (setq rest (cdr rest)) |
1591 (cond ((= tmp 1) | 1591 (cond ((= tmp 1) |
1592 (byte-compile-log-lap | 1592 (byte-compile-log-lap |
1593 " %s discard\t-->\t<deleted>" lap0) | 1593 " %s discard\t-->\t<deleted>" lap0) |
1594 (setq lap (delq lap0 (delq lap1 lap)))) | 1594 (setq lap (delete* lap0 (delete* lap1 lap)))) |
1595 ((= tmp 0) | 1595 ((= tmp 0) |
1596 (byte-compile-log-lap | 1596 (byte-compile-log-lap |
1597 " %s discard\t-->\t<deleted> discard" lap0) | 1597 " %s discard\t-->\t<deleted> discard" lap0) |
1598 (setq lap (delq lap0 lap))) | 1598 (setq lap (delete* lap0 lap))) |
1599 ((= tmp -1) | 1599 ((= tmp -1) |
1600 (byte-compile-log-lap | 1600 (byte-compile-log-lap |
1601 " %s discard\t-->\tdiscard discard" lap0) | 1601 " %s discard\t-->\tdiscard discard" lap0) |
1602 (setcar lap0 'byte-discard) | 1602 (setcar lap0 'byte-discard) |
1603 (setcdr lap0 0)) | 1603 (setcdr lap0 0)) |
1606 ;; goto*-X X: --> X: | 1606 ;; goto*-X X: --> X: |
1607 ;; | 1607 ;; |
1608 ((and (memq (car lap0) byte-goto-ops) | 1608 ((and (memq (car lap0) byte-goto-ops) |
1609 (eq (cdr lap0) lap1)) | 1609 (eq (cdr lap0) lap1)) |
1610 (cond ((eq (car lap0) 'byte-goto) | 1610 (cond ((eq (car lap0) 'byte-goto) |
1611 (setq lap (delq lap0 lap)) | 1611 (setq lap (delete* lap0 lap)) |
1612 (setq tmp "<deleted>")) | 1612 (setq tmp "<deleted>")) |
1613 ((memq (car lap0) byte-goto-always-pop-ops) | 1613 ((memq (car lap0) byte-goto-always-pop-ops) |
1614 (setcar lap0 (setq tmp 'byte-discard)) | 1614 (setcar lap0 (setq tmp 'byte-discard)) |
1615 (setcdr lap0 0)) | 1615 (setcdr lap0 0)) |
1616 ((error "Depth conflict at tag %d" (nth 2 lap0)))) | 1616 ((error "Depth conflict at tag %d" (nth 2 lap0)))) |
1663 (eq 'byte-discard (car lap2)) | 1663 (eq 'byte-discard (car lap2)) |
1664 (memq (car lap1) '(byte-varset byte-varbind))) | 1664 (memq (car lap1) '(byte-varset byte-varbind))) |
1665 (byte-compile-log-lap " dup %s discard\t-->\t%s" lap1 lap1) | 1665 (byte-compile-log-lap " dup %s discard\t-->\t%s" lap1 lap1) |
1666 (setq keep-going t | 1666 (setq keep-going t |
1667 rest (cdr rest)) | 1667 rest (cdr rest)) |
1668 (setq lap (delq lap0 (delq lap2 lap)))) | 1668 (setq lap (delete* lap0 (delete* lap2 lap)))) |
1669 ;; | 1669 ;; |
1670 ;; not goto-X-if-nil --> goto-X-if-non-nil | 1670 ;; not goto-X-if-nil --> goto-X-if-non-nil |
1671 ;; not goto-X-if-non-nil --> goto-X-if-nil | 1671 ;; not goto-X-if-non-nil --> goto-X-if-nil |
1672 ;; | 1672 ;; |
1673 ;; it is wrong to do the same thing for the -else-pop variants. | 1673 ;; it is wrong to do the same thing for the -else-pop variants. |
1683 'byte-goto-if-nil) | 1683 'byte-goto-if-nil) |
1684 (cdr lap1))) | 1684 (cdr lap1))) |
1685 (setcar lap1 (if (eq (car lap1) 'byte-goto-if-nil) | 1685 (setcar lap1 (if (eq (car lap1) 'byte-goto-if-nil) |
1686 'byte-goto-if-not-nil | 1686 'byte-goto-if-not-nil |
1687 'byte-goto-if-nil)) | 1687 'byte-goto-if-nil)) |
1688 (setq lap (delq lap0 lap)) | 1688 (setq lap (delete* lap0 lap)) |
1689 (setq keep-going t)) | 1689 (setq keep-going t)) |
1690 ;; | 1690 ;; |
1691 ;; goto-X-if-nil goto-Y X: --> goto-Y-if-non-nil X: | 1691 ;; goto-X-if-nil goto-Y X: --> goto-Y-if-non-nil X: |
1692 ;; goto-X-if-non-nil goto-Y X: --> goto-Y-if-nil X: | 1692 ;; goto-X-if-non-nil goto-Y X: --> goto-Y-if-nil X: |
1693 ;; | 1693 ;; |
1700 (let ((inverse (if (eq 'byte-goto-if-nil (car lap0)) | 1700 (let ((inverse (if (eq 'byte-goto-if-nil (car lap0)) |
1701 'byte-goto-if-not-nil 'byte-goto-if-nil))) | 1701 'byte-goto-if-not-nil 'byte-goto-if-nil))) |
1702 (byte-compile-log-lap " %s %s %s:\t-->\t%s %s:" | 1702 (byte-compile-log-lap " %s %s %s:\t-->\t%s %s:" |
1703 lap0 lap1 lap2 | 1703 lap0 lap1 lap2 |
1704 (cons inverse (cdr lap1)) lap2) | 1704 (cons inverse (cdr lap1)) lap2) |
1705 (setq lap (delq lap0 lap)) | 1705 (setq lap (delete* lap0 lap)) |
1706 (setcar lap1 inverse) | 1706 (setcar lap1 inverse) |
1707 (setq keep-going t))) | 1707 (setq keep-going t))) |
1708 ;; | 1708 ;; |
1709 ;; const goto-if-* --> whatever | 1709 ;; const goto-if-* --> whatever |
1710 ;; | 1710 ;; |
1715 (car (cdr lap0)) | 1715 (car (cdr lap0)) |
1716 (not (car (cdr lap0)))) | 1716 (not (car (cdr lap0)))) |
1717 (byte-compile-log-lap " %s %s\t-->\t<deleted>" | 1717 (byte-compile-log-lap " %s %s\t-->\t<deleted>" |
1718 lap0 lap1) | 1718 lap0 lap1) |
1719 (setq rest (cdr rest) | 1719 (setq rest (cdr rest) |
1720 lap (delq lap0 (delq lap1 lap)))) | 1720 lap (delete* lap0 (delete* lap1 lap)))) |
1721 (t | 1721 (t |
1722 (if (memq (car lap1) byte-goto-always-pop-ops) | 1722 (if (memq (car lap1) byte-goto-always-pop-ops) |
1723 (progn | 1723 (progn |
1724 (byte-compile-log-lap " %s %s\t-->\t%s" | 1724 (byte-compile-log-lap " %s %s\t-->\t%s" |
1725 lap0 lap1 (cons 'byte-goto (cdr lap1))) | 1725 lap0 lap1 (cons 'byte-goto (cdr lap1))) |
1726 (setq lap (delq lap0 lap))) | 1726 (setq lap (delete* lap0 lap))) |
1727 (byte-compile-log-lap " %s %s\t-->\t%s" lap0 lap1 | 1727 (byte-compile-log-lap " %s %s\t-->\t%s" lap0 lap1 |
1728 (cons 'byte-goto (cdr lap1)))) | 1728 (cons 'byte-goto (cdr lap1)))) |
1729 (setcar lap1 'byte-goto))) | 1729 (setcar lap1 'byte-goto))) |
1730 (setq keep-going t)) | 1730 (setq keep-going t)) |
1731 ;; | 1731 ;; |
1766 (nth 1 lap1) (nth 1 lap0))) | 1766 (nth 1 lap1) (nth 1 lap0))) |
1767 (setq tmp3 lap) | 1767 (setq tmp3 lap) |
1768 (while (setq tmp2 (rassq lap0 tmp3)) | 1768 (while (setq tmp2 (rassq lap0 tmp3)) |
1769 (setcdr tmp2 lap1) | 1769 (setcdr tmp2 lap1) |
1770 (setq tmp3 (cdr (memq tmp2 tmp3)))) | 1770 (setq tmp3 (cdr (memq tmp2 tmp3)))) |
1771 (setq lap (delq lap0 lap) | 1771 (setq lap (delete* lap0 lap) |
1772 keep-going t)) | 1772 keep-going t)) |
1773 ;; | 1773 ;; |
1774 ;; unused-TAG: --> <deleted> | 1774 ;; unused-TAG: --> <deleted> |
1775 ;; | 1775 ;; |
1776 ((and (eq 'TAG (car lap0)) | 1776 ((and (eq 'TAG (car lap0)) |
1777 (not (rassq lap0 lap))) | 1777 (not (rassq lap0 lap))) |
1778 (and (memq byte-optimize-log '(t byte)) | 1778 (and (memq byte-optimize-log '(t byte)) |
1779 (byte-compile-log " unused tag %d removed" (nth 1 lap0))) | 1779 (byte-compile-log " unused tag %d removed" (nth 1 lap0))) |
1780 (setq lap (delq lap0 lap) | 1780 (setq lap (delete* lap0 lap) |
1781 keep-going t)) | 1781 keep-going t)) |
1782 ;; | 1782 ;; |
1783 ;; goto ... --> goto <delete until TAG or end> | 1783 ;; goto ... --> goto <delete until TAG or end> |
1784 ;; return ... --> return <delete until TAG or end> | 1784 ;; return ... --> return <delete until TAG or end> |
1785 ;; | 1785 ;; |
1830 ((and (eq 'byte-unbind (car lap1)) | 1830 ((and (eq 'byte-unbind (car lap1)) |
1831 (memq (car lap0) '(byte-varbind byte-save-excursion | 1831 (memq (car lap0) '(byte-varbind byte-save-excursion |
1832 byte-save-restriction)) | 1832 byte-save-restriction)) |
1833 (< 0 (cdr lap1))) | 1833 (< 0 (cdr lap1))) |
1834 (if (zerop (setcdr lap1 (1- (cdr lap1)))) | 1834 (if (zerop (setcdr lap1 (1- (cdr lap1)))) |
1835 (delq lap1 rest)) | 1835 (delete* lap1 rest)) |
1836 (if (eq (car lap0) 'byte-varbind) | 1836 (if (eq (car lap0) 'byte-varbind) |
1837 (setcar rest (cons 'byte-discard 0)) | 1837 (setcar rest (cons 'byte-discard 0)) |
1838 (setq lap (delq lap0 lap))) | 1838 (setq lap (delete* lap0 lap))) |
1839 (byte-compile-log-lap " %s %s\t-->\t%s %s" | 1839 (byte-compile-log-lap " %s %s\t-->\t%s %s" |
1840 lap0 (cons (car lap1) (1+ (cdr lap1))) | 1840 lap0 (cons (car lap1) (1+ (cdr lap1))) |
1841 (if (eq (car lap0) 'byte-varbind) | 1841 (if (eq (car lap0) 'byte-varbind) |
1842 (car rest) | 1842 (car rest) |
1843 (car (cdr rest))) | 1843 (car (cdr rest))) |
1920 lap0 tmp2) | 1920 lap0 tmp2) |
1921 (or (eq 'TAG (car (nth 1 tmp))) | 1921 (or (eq 'TAG (car (nth 1 tmp))) |
1922 (setcdr tmp (cons (byte-compile-make-tag) | 1922 (setcdr tmp (cons (byte-compile-make-tag) |
1923 (cdr tmp)))) | 1923 (cdr tmp)))) |
1924 (setcdr lap1 (car (cdr tmp))) | 1924 (setcdr lap1 (car (cdr tmp))) |
1925 (setq lap (delq lap0 lap)))) | 1925 (setq lap (delete* lap0 lap)))) |
1926 (setq keep-going t)) | 1926 (setq keep-going t)) |
1927 ;; | 1927 ;; |
1928 ;; X: varref-Y ... varset-Y goto-X --> | 1928 ;; X: varref-Y ... varset-Y goto-X --> |
1929 ;; X: varref-Y Z: ... dup varset-Y goto-Z | 1929 ;; X: varref-Y Z: ... dup varset-Y goto-Z |
1930 ;; (varset-X goto-BACK, BACK: varref-X --> copy the varref down.) | 1930 ;; (varset-X goto-BACK, BACK: varref-X --> copy the varref down.) |
2056 (eq 'byte-unbind (car lap1))) | 2056 (eq 'byte-unbind (car lap1))) |
2057 (byte-compile-log-lap " %s %s\t-->\t%s" lap0 lap1 | 2057 (byte-compile-log-lap " %s %s\t-->\t%s" lap0 lap1 |
2058 (cons 'byte-unbind | 2058 (cons 'byte-unbind |
2059 (+ (cdr lap0) (cdr lap1)))) | 2059 (+ (cdr lap0) (cdr lap1)))) |
2060 (setq keep-going t) | 2060 (setq keep-going t) |
2061 (setq lap (delq lap0 lap)) | 2061 (setq lap (delete* lap0 lap)) |
2062 (setcdr lap1 (+ (cdr lap1) (cdr lap0)))) | 2062 (setcdr lap1 (+ (cdr lap1) (cdr lap0)))) |
2063 ) | 2063 ) |
2064 (setq rest (cdr rest))) | 2064 (setq rest (cdr rest))) |
2065 ;; Since the first 6 entries of the compiled-function constants | 2065 ;; Since the first 6 entries of the compiled-function constants |
2066 ;; vector are most efficient for varref/set/bind ops, we sort by | 2066 ;; vector are most efficient for varref/set/bind ops, we sort by |