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