aboutsummaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorStefan Monnier2021-01-20 13:54:11 -0500
committerStefan Monnier2021-01-20 14:13:15 -0500
commit09bfb12edc57ace138090861e335366d8f1cc4b2 (patch)
tree4376201648d122bca972bfc5ef7fbb29808e055f
parent434057ad925cad3ebcae1802fab60733ae5decae (diff)
downloademacs-09bfb12edc57ace138090861e335366d8f1cc4b2.tar.gz
emacs-09bfb12edc57ace138090861e335366d8f1cc4b2.zip
* lisp/emacs-lisp/byte-opt.el (byte-optimize-lapcode): Re-indent
Diffstat
-rw-r--r--lisp/emacs-lisp/byte-opt.el914
1 files changed, 457 insertions, 457 deletions
diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el
index f29f85b9650..6d1f4179ce1 100644
--- a/lisp/emacs-lisp/byte-opt.el
+++ b/lisp/emacs-lisp/byte-opt.el
@@ -1561,467 +1561,467 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance."
1561 ;; You may notice that sequences like "dup varset discard" are 1561 ;; You may notice that sequences like "dup varset discard" are
1562 ;; optimized but sequences like "dup varset TAG1: discard" are not. 1562 ;; optimized but sequences like "dup varset TAG1: discard" are not.
1563 ;; You may be tempted to change this; resist that temptation. 1563 ;; You may be tempted to change this; resist that temptation.
1564 (cond ;; 1564 (cond
1565 ;; <side-effect-free> pop --> <deleted> 1565 ;; <side-effect-free> pop --> <deleted>
1566 ;; ...including: 1566 ;; ...including:
1567 ;; const-X pop --> <deleted> 1567 ;; const-X pop --> <deleted>
1568 ;; varref-X pop --> <deleted> 1568 ;; varref-X pop --> <deleted>
1569 ;; dup pop --> <deleted> 1569 ;; dup pop --> <deleted>
1570 ;; 1570 ;;
1571 ((and (eq 'byte-discard (car lap1)) 1571 ((and (eq 'byte-discard (car lap1))
1572 (memq (car lap0) side-effect-free)) 1572 (memq (car lap0) side-effect-free))
1573 (setq keep-going t) 1573 (setq keep-going t)
1574 (setq tmp (aref byte-stack+-info (symbol-value (car lap0)))) 1574 (setq tmp (aref byte-stack+-info (symbol-value (car lap0))))
1575 (setq rest (cdr rest)) 1575 (setq rest (cdr rest))
1576 (cond ((= tmp 1) 1576 (cond ((= tmp 1)
1577 (byte-compile-log-lap 1577 (byte-compile-log-lap
1578 " %s discard\t-->\t<deleted>" lap0) 1578 " %s discard\t-->\t<deleted>" lap0)
1579 (setq lap (delq lap0 (delq lap1 lap)))) 1579 (setq lap (delq lap0 (delq lap1 lap))))
1580 ((= tmp 0) 1580 ((= tmp 0)
1581 (byte-compile-log-lap 1581 (byte-compile-log-lap
1582 " %s discard\t-->\t<deleted> discard" lap0) 1582 " %s discard\t-->\t<deleted> discard" lap0)
1583 (setq lap (delq lap0 lap)))
1584 ((= tmp -1)
1585 (byte-compile-log-lap
1586 " %s discard\t-->\tdiscard discard" lap0)
1587 (setcar lap0 'byte-discard)
1588 (setcdr lap0 0))
1589 ((error "Optimizer error: too much on the stack"))))
1590 ;;
1591 ;; goto*-X X: --> X:
1592 ;;
1593 ((and (memq (car lap0) byte-goto-ops)
1594 (eq (cdr lap0) lap1))
1595 (cond ((eq (car lap0) 'byte-goto)
1596 (setq lap (delq lap0 lap))
1597 (setq tmp "<deleted>"))
1598 ((memq (car lap0) byte-goto-always-pop-ops)
1599 (setcar lap0 (setq tmp 'byte-discard))
1600 (setcdr lap0 0))
1601 ((error "Depth conflict at tag %d" (nth 2 lap0))))
1602 (and (memq byte-optimize-log '(t byte))
1603 (byte-compile-log " (goto %s) %s:\t-->\t%s %s:"
1604 (nth 1 lap1) (nth 1 lap1)
1605 tmp (nth 1 lap1)))
1606 (setq keep-going t))
1607 ;;
1608 ;; varset-X varref-X --> dup varset-X
1609 ;; varbind-X varref-X --> dup varbind-X
1610 ;; const/dup varset-X varref-X --> const/dup varset-X const/dup
1611 ;; const/dup varbind-X varref-X --> const/dup varbind-X const/dup
1612 ;; The latter two can enable other optimizations.
1613 ;;
1614 ;; For lexical variables, we could do the same
1615 ;; stack-set-X+1 stack-ref-X --> dup stack-set-X+2
1616 ;; but this is a very minor gain, since dup is stack-ref-0,
1617 ;; i.e. it's only better if X>5, and even then it comes
1618 ;; at the cost of an extra stack slot. Let's not bother.
1619 ((and (eq 'byte-varref (car lap2))
1620 (eq (cdr lap1) (cdr lap2))
1621 (memq (car lap1) '(byte-varset byte-varbind)))
1622 (if (and (setq tmp (memq (car (cdr lap2)) byte-boolean-vars))
1623 (not (eq (car lap0) 'byte-constant)))
1624 nil
1625 (setq keep-going t)
1626 (if (memq (car lap0) '(byte-constant byte-dup))
1627 (progn
1628 (setq tmp (if (or (not tmp)
1629 (macroexp--const-symbol-p
1630 (car (cdr lap0))))
1631 (cdr lap0)
1632 (byte-compile-get-constant t)))
1633 (byte-compile-log-lap " %s %s %s\t-->\t%s %s %s"
1634 lap0 lap1 lap2 lap0 lap1
1635 (cons (car lap0) tmp))
1636 (setcar lap2 (car lap0))
1637 (setcdr lap2 tmp))
1638 (byte-compile-log-lap " %s %s\t-->\tdup %s" lap1 lap2 lap1)
1639 (setcar lap2 (car lap1))
1640 (setcar lap1 'byte-dup)
1641 (setcdr lap1 0)
1642 ;; The stack depth gets locally increased, so we will
1643 ;; increase maxdepth in case depth = maxdepth here.
1644 ;; This can cause the third argument to byte-code to
1645 ;; be larger than necessary.
1646 (setq add-depth 1))))
1647 ;;
1648 ;; dup varset-X discard --> varset-X
1649 ;; dup varbind-X discard --> varbind-X
1650 ;; dup stack-set-X discard --> stack-set-X-1
1651 ;; (the varbind variant can emerge from other optimizations)
1652 ;;
1653 ((and (eq 'byte-dup (car lap0))
1654 (eq 'byte-discard (car lap2))
1655 (memq (car lap1) '(byte-varset byte-varbind
1656 byte-stack-set)))
1657 (byte-compile-log-lap " dup %s discard\t-->\t%s" lap1 lap1)
1658 (setq keep-going t
1659 rest (cdr rest))
1660 (if (eq 'byte-stack-set (car lap1)) (cl-decf (cdr lap1)))
1661 (setq lap (delq lap0 (delq lap2 lap))))
1662 ;;
1663 ;; not goto-X-if-nil --> goto-X-if-non-nil
1664 ;; not goto-X-if-non-nil --> goto-X-if-nil
1665 ;;
1666 ;; it is wrong to do the same thing for the -else-pop variants.
1667 ;;
1668 ((and (eq 'byte-not (car lap0))
1669 (memq (car lap1) '(byte-goto-if-nil byte-goto-if-not-nil)))
1670 (byte-compile-log-lap " not %s\t-->\t%s"
1671 lap1
1672 (cons
1673 (if (eq (car lap1) 'byte-goto-if-nil)
1674 'byte-goto-if-not-nil
1675 'byte-goto-if-nil)
1676 (cdr lap1)))
1677 (setcar lap1 (if (eq (car lap1) 'byte-goto-if-nil)
1678 'byte-goto-if-not-nil
1679 'byte-goto-if-nil))
1680 (setq lap (delq lap0 lap))
1681 (setq keep-going t))
1682 ;;
1683 ;; goto-X-if-nil goto-Y X: --> goto-Y-if-non-nil X:
1684 ;; goto-X-if-non-nil goto-Y X: --> goto-Y-if-nil X:
1685 ;;
1686 ;; it is wrong to do the same thing for the -else-pop variants.
1687 ;;
1688 ((and (memq (car lap0)
1689 '(byte-goto-if-nil byte-goto-if-not-nil)) ; gotoX
1690 (eq 'byte-goto (car lap1)) ; gotoY
1691 (eq (cdr lap0) lap2)) ; TAG X
1692 (let ((inverse (if (eq 'byte-goto-if-nil (car lap0))
1693 'byte-goto-if-not-nil 'byte-goto-if-nil)))
1694 (byte-compile-log-lap " %s %s %s:\t-->\t%s %s:"
1695 lap0 lap1 lap2
1696 (cons inverse (cdr lap1)) lap2)
1697 (setq lap (delq lap0 lap))
1698 (setcar lap1 inverse)
1699 (setq keep-going t)))
1700 ;;
1701 ;; const goto-if-* --> whatever
1702 ;;
1703 ((and (eq 'byte-constant (car lap0))
1704 (memq (car lap1) byte-conditional-ops)
1705 ;; If the `byte-constant's cdr is not a cons cell, it has
1706 ;; to be an index into the constant pool); even though
1707 ;; it'll be a constant, that constant is not known yet
1708 ;; (it's typically a free variable of a closure, so will
1709 ;; only be known when the closure will be built at
1710 ;; run-time).
1711 (consp (cdr lap0)))
1712 (cond ((if (memq (car lap1) '(byte-goto-if-nil
1713 byte-goto-if-nil-else-pop))
1714 (car (cdr lap0))
1715 (not (car (cdr lap0))))
1716 (byte-compile-log-lap " %s %s\t-->\t<deleted>"
1717 lap0 lap1)
1718 (setq rest (cdr rest)
1719 lap (delq lap0 (delq lap1 lap))))
1720 (t
1721 (byte-compile-log-lap " %s %s\t-->\t%s"
1722 lap0 lap1
1723 (cons 'byte-goto (cdr lap1)))
1724 (when (memq (car lap1) byte-goto-always-pop-ops)
1725 (setq lap (delq lap0 lap)))
1726 (setcar lap1 'byte-goto)))
1727 (setq keep-going t))
1728 ;;
1729 ;; varref-X varref-X --> varref-X dup
1730 ;; varref-X [dup ...] varref-X --> varref-X [dup ...] dup
1731 ;; stackref-X [dup ...] stackref-X+N --> stackref-X [dup ...] dup
1732 ;; We don't optimize the const-X variations on this here,
1733 ;; because that would inhibit some goto optimizations; we
1734 ;; optimize the const-X case after all other optimizations.
1735 ;;
1736 ((and (memq (car lap0) '(byte-varref byte-stack-ref))
1737 (progn
1738 (setq tmp (cdr rest))
1739 (setq tmp2 0)
1740 (while (eq (car (car tmp)) 'byte-dup)
1741 (setq tmp2 (1+ tmp2))
1742 (setq tmp (cdr tmp)))
1743 t)
1744 (eq (if (eq 'byte-stack-ref (car lap0))
1745 (+ tmp2 1 (cdr lap0))
1746 (cdr lap0))
1747 (cdr (car tmp)))
1748 (eq (car lap0) (car (car tmp))))
1749 (if (memq byte-optimize-log '(t byte))
1750 (let ((str ""))
1751 (setq tmp2 (cdr rest))
1752 (while (not (eq tmp tmp2))
1753 (setq tmp2 (cdr tmp2)
1754 str (concat str " dup")))
1755 (byte-compile-log-lap " %s%s %s\t-->\t%s%s dup"
1756 lap0 str lap0 lap0 str)))
1757 (setq keep-going t)
1758 (setcar (car tmp) 'byte-dup)
1759 (setcdr (car tmp) 0)
1760 (setq rest tmp))
1761 ;;
1762 ;; TAG1: TAG2: --> TAG1: <deleted>
1763 ;; (and other references to TAG2 are replaced with TAG1)
1764 ;;
1765 ((and (eq (car lap0) 'TAG)
1766 (eq (car lap1) 'TAG))
1767 (and (memq byte-optimize-log '(t byte))
1768 (byte-compile-log " adjacent tags %d and %d merged"
1769 (nth 1 lap1) (nth 1 lap0)))
1770 (setq tmp3 lap)
1771 (while (setq tmp2 (rassq lap0 tmp3))
1772 (setcdr tmp2 lap1)
1773 (setq tmp3 (cdr (memq tmp2 tmp3))))
1774 (setq lap (delq lap0 lap)
1775 keep-going t)
1776 ;; replace references to tag in jump tables, if any
1777 (dolist (table byte-compile-jump-tables)
1778 (maphash #'(lambda (value tag)
1779 (when (equal tag lap0)
1780 (puthash value lap1 table)))
1781 table)))
1782 ;;
1783 ;; unused-TAG: --> <deleted>
1784 ;;
1785 ((and (eq 'TAG (car lap0))
1786 (not (rassq lap0 lap))
1787 ;; make sure this tag isn't used in a jump-table
1788 (cl-loop for table in byte-compile-jump-tables
1789 when (member lap0 (hash-table-values table))
1790 return nil finally return t))
1791 (and (memq byte-optimize-log '(t byte))
1792 (byte-compile-log " unused tag %d removed" (nth 1 lap0)))
1793 (setq lap (delq lap0 lap)
1794 keep-going t))
1795 ;;
1796 ;; goto ... --> goto <delete until TAG or end>
1797 ;; return ... --> return <delete until TAG or end>
1798 ;; (unless a jump-table is being used, where deleting may affect
1799 ;; other valid case bodies)
1800 ;;
1801 ((and (memq (car lap0) '(byte-goto byte-return))
1802 (not (memq (car lap1) '(TAG nil)))
1803 ;; FIXME: Instead of deferring simply when jump-tables are
1804 ;; being used, keep a list of tags used for switch tags and
1805 ;; use them instead (see `byte-compile-inline-lapcode').
1806 (not byte-compile-jump-tables))
1807 (setq tmp rest)
1808 (let ((i 0)
1809 (opt-p (memq byte-optimize-log '(t lap)))
1810 str deleted)
1811 (while (and (setq tmp (cdr tmp))
1812 (not (eq 'TAG (car (car tmp)))))
1813 (if opt-p (setq deleted (cons (car tmp) deleted)
1814 str (concat str " %s")
1815 i (1+ i))))
1816 (if opt-p
1817 (let ((tagstr
1818 (if (eq 'TAG (car (car tmp)))
1819 (format "%d:" (car (cdr (car tmp))))
1820 (or (car tmp) ""))))
1821 (if (< i 6)
1822 (apply 'byte-compile-log-lap-1
1823 (concat " %s" str
1824 " %s\t-->\t%s <deleted> %s")
1825 lap0
1826 (nconc (nreverse deleted)
1827 (list tagstr lap0 tagstr)))
1828 (byte-compile-log-lap
1829 " %s <%d unreachable op%s> %s\t-->\t%s <deleted> %s"
1830 lap0 i (if (= i 1) "" "s")
1831 tagstr lap0 tagstr))))
1832 (rplacd rest tmp))
1833 (setq keep-going t))
1834 ;;
1835 ;; <safe-op> unbind --> unbind <safe-op>
1836 ;; (this may enable other optimizations.)
1837 ;;
1838 ((and (eq 'byte-unbind (car lap1))
1839 (memq (car lap0) byte-after-unbind-ops))
1840 (byte-compile-log-lap " %s %s\t-->\t%s %s" lap0 lap1 lap1 lap0)
1841 (setcar rest lap1)
1842 (setcar (cdr rest) lap0)
1843 (setq keep-going t))
1844 ;;
1845 ;; varbind-X unbind-N --> discard unbind-(N-1)
1846 ;; save-excursion unbind-N --> unbind-(N-1)
1847 ;; save-restriction unbind-N --> unbind-(N-1)
1848 ;;
1849 ((and (eq 'byte-unbind (car lap1))
1850 (memq (car lap0) '(byte-varbind byte-save-excursion
1851 byte-save-restriction))
1852 (< 0 (cdr lap1)))
1853 (if (zerop (setcdr lap1 (1- (cdr lap1))))
1854 (delq lap1 rest))
1855 (if (eq (car lap0) 'byte-varbind)
1856 (setcar rest (cons 'byte-discard 0))
1857 (setq lap (delq lap0 lap))) 1583 (setq lap (delq lap0 lap)))
1858 (byte-compile-log-lap " %s %s\t-->\t%s %s" 1584 ((= tmp -1)
1859 lap0 (cons (car lap1) (1+ (cdr lap1))) 1585 (byte-compile-log-lap
1860 (if (eq (car lap0) 'byte-varbind) 1586 " %s discard\t-->\tdiscard discard" lap0)
1861 (car rest) 1587 (setcar lap0 'byte-discard)
1862 (car (cdr rest))) 1588 (setcdr lap0 0))
1863 (if (and (/= 0 (cdr lap1)) 1589 ((error "Optimizer error: too much on the stack"))))
1864 (eq (car lap0) 'byte-varbind)) 1590 ;;
1865 (car (cdr rest)) 1591 ;; goto*-X X: --> X:
1866 "")) 1592 ;;
1867 (setq keep-going t)) 1593 ((and (memq (car lap0) byte-goto-ops)
1868 ;; 1594 (eq (cdr lap0) lap1))
1869 ;; goto*-X ... X: goto-Y --> goto*-Y 1595 (cond ((eq (car lap0) 'byte-goto)
1870 ;; goto-X ... X: return --> return 1596 (setq lap (delq lap0 lap))
1871 ;; 1597 (setq tmp "<deleted>"))
1872 ((and (memq (car lap0) byte-goto-ops) 1598 ((memq (car lap0) byte-goto-always-pop-ops)
1873 (memq (car (setq tmp (nth 1 (memq (cdr lap0) lap)))) 1599 (setcar lap0 (setq tmp 'byte-discard))
1874 '(byte-goto byte-return))) 1600 (setcdr lap0 0))
1875 (cond ((and (not (eq tmp lap0)) 1601 ((error "Depth conflict at tag %d" (nth 2 lap0))))
1876 (or (eq (car lap0) 'byte-goto) 1602 (and (memq byte-optimize-log '(t byte))
1877 (eq (car tmp) 'byte-goto))) 1603 (byte-compile-log " (goto %s) %s:\t-->\t%s %s:"
1878 (byte-compile-log-lap " %s [%s]\t-->\t%s" 1604 (nth 1 lap1) (nth 1 lap1)
1879 (car lap0) tmp tmp) 1605 tmp (nth 1 lap1)))
1880 (if (eq (car tmp) 'byte-return) 1606 (setq keep-going t))
1881 (setcar lap0 'byte-return)) 1607 ;;
1882 (setcdr lap0 (cdr tmp)) 1608 ;; varset-X varref-X --> dup varset-X
1883 (setq keep-going t)))) 1609 ;; varbind-X varref-X --> dup varbind-X
1884 ;; 1610 ;; const/dup varset-X varref-X --> const/dup varset-X const/dup
1885 ;; goto-*-else-pop X ... X: goto-if-* --> whatever 1611 ;; const/dup varbind-X varref-X --> const/dup varbind-X const/dup
1886 ;; goto-*-else-pop X ... X: discard --> whatever 1612 ;; The latter two can enable other optimizations.
1887 ;; 1613 ;;
1888 ((and (memq (car lap0) '(byte-goto-if-nil-else-pop 1614 ;; For lexical variables, we could do the same
1889 byte-goto-if-not-nil-else-pop)) 1615 ;; stack-set-X+1 stack-ref-X --> dup stack-set-X+2
1890 (memq (car (car (setq tmp (cdr (memq (cdr lap0) lap))))) 1616 ;; but this is a very minor gain, since dup is stack-ref-0,
1891 (eval-when-compile 1617 ;; i.e. it's only better if X>5, and even then it comes
1892 (cons 'byte-discard byte-conditional-ops))) 1618 ;; at the cost of an extra stack slot. Let's not bother.
1893 (not (eq lap0 (car tmp)))) 1619 ((and (eq 'byte-varref (car lap2))
1894 (setq tmp2 (car tmp)) 1620 (eq (cdr lap1) (cdr lap2))
1895 (setq tmp3 (assq (car lap0) '((byte-goto-if-nil-else-pop 1621 (memq (car lap1) '(byte-varset byte-varbind)))
1896 byte-goto-if-nil) 1622 (if (and (setq tmp (memq (car (cdr lap2)) byte-boolean-vars))
1897 (byte-goto-if-not-nil-else-pop 1623 (not (eq (car lap0) 'byte-constant)))
1898 byte-goto-if-not-nil)))) 1624 nil
1899 (if (memq (car tmp2) tmp3) 1625 (setq keep-going t)
1900 (progn (setcar lap0 (car tmp2)) 1626 (if (memq (car lap0) '(byte-constant byte-dup))
1901 (setcdr lap0 (cdr tmp2)) 1627 (progn
1902 (byte-compile-log-lap " %s-else-pop [%s]\t-->\t%s" 1628 (setq tmp (if (or (not tmp)
1903 (car lap0) tmp2 lap0)) 1629 (macroexp--const-symbol-p
1904 ;; Get rid of the -else-pop's and jump one step further. 1630 (car (cdr lap0))))
1631 (cdr lap0)
1632 (byte-compile-get-constant t)))
1633 (byte-compile-log-lap " %s %s %s\t-->\t%s %s %s"
1634 lap0 lap1 lap2 lap0 lap1
1635 (cons (car lap0) tmp))
1636 (setcar lap2 (car lap0))
1637 (setcdr lap2 tmp))
1638 (byte-compile-log-lap " %s %s\t-->\tdup %s" lap1 lap2 lap1)
1639 (setcar lap2 (car lap1))
1640 (setcar lap1 'byte-dup)
1641 (setcdr lap1 0)
1642 ;; The stack depth gets locally increased, so we will
1643 ;; increase maxdepth in case depth = maxdepth here.
1644 ;; This can cause the third argument to byte-code to
1645 ;; be larger than necessary.
1646 (setq add-depth 1))))
1647 ;;
1648 ;; dup varset-X discard --> varset-X
1649 ;; dup varbind-X discard --> varbind-X
1650 ;; dup stack-set-X discard --> stack-set-X-1
1651 ;; (the varbind variant can emerge from other optimizations)
1652 ;;
1653 ((and (eq 'byte-dup (car lap0))
1654 (eq 'byte-discard (car lap2))
1655 (memq (car lap1) '(byte-varset byte-varbind
1656 byte-stack-set)))
1657 (byte-compile-log-lap " dup %s discard\t-->\t%s" lap1 lap1)
1658 (setq keep-going t
1659 rest (cdr rest))
1660 (if (eq 'byte-stack-set (car lap1)) (cl-decf (cdr lap1)))
1661 (setq lap (delq lap0 (delq lap2 lap))))
1662 ;;
1663 ;; not goto-X-if-nil --> goto-X-if-non-nil
1664 ;; not goto-X-if-non-nil --> goto-X-if-nil
1665 ;;
1666 ;; it is wrong to do the same thing for the -else-pop variants.
1667 ;;
1668 ((and (eq 'byte-not (car lap0))
1669 (memq (car lap1) '(byte-goto-if-nil byte-goto-if-not-nil)))
1670 (byte-compile-log-lap " not %s\t-->\t%s"
1671 lap1
1672 (cons
1673 (if (eq (car lap1) 'byte-goto-if-nil)
1674 'byte-goto-if-not-nil
1675 'byte-goto-if-nil)
1676 (cdr lap1)))
1677 (setcar lap1 (if (eq (car lap1) 'byte-goto-if-nil)
1678 'byte-goto-if-not-nil
1679 'byte-goto-if-nil))
1680 (setq lap (delq lap0 lap))
1681 (setq keep-going t))
1682 ;;
1683 ;; goto-X-if-nil goto-Y X: --> goto-Y-if-non-nil X:
1684 ;; goto-X-if-non-nil goto-Y X: --> goto-Y-if-nil X:
1685 ;;
1686 ;; it is wrong to do the same thing for the -else-pop variants.
1687 ;;
1688 ((and (memq (car lap0)
1689 '(byte-goto-if-nil byte-goto-if-not-nil)) ; gotoX
1690 (eq 'byte-goto (car lap1)) ; gotoY
1691 (eq (cdr lap0) lap2)) ; TAG X
1692 (let ((inverse (if (eq 'byte-goto-if-nil (car lap0))
1693 'byte-goto-if-not-nil 'byte-goto-if-nil)))
1694 (byte-compile-log-lap " %s %s %s:\t-->\t%s %s:"
1695 lap0 lap1 lap2
1696 (cons inverse (cdr lap1)) lap2)
1697 (setq lap (delq lap0 lap))
1698 (setcar lap1 inverse)
1699 (setq keep-going t)))
1700 ;;
1701 ;; const goto-if-* --> whatever
1702 ;;
1703 ((and (eq 'byte-constant (car lap0))
1704 (memq (car lap1) byte-conditional-ops)
1705 ;; If the `byte-constant's cdr is not a cons cell, it has
1706 ;; to be an index into the constant pool); even though
1707 ;; it'll be a constant, that constant is not known yet
1708 ;; (it's typically a free variable of a closure, so will
1709 ;; only be known when the closure will be built at
1710 ;; run-time).
1711 (consp (cdr lap0)))
1712 (cond ((if (memq (car lap1) '(byte-goto-if-nil
1713 byte-goto-if-nil-else-pop))
1714 (car (cdr lap0))
1715 (not (car (cdr lap0))))
1716 (byte-compile-log-lap " %s %s\t-->\t<deleted>"
1717 lap0 lap1)
1718 (setq rest (cdr rest)
1719 lap (delq lap0 (delq lap1 lap))))
1720 (t
1721 (byte-compile-log-lap " %s %s\t-->\t%s"
1722 lap0 lap1
1723 (cons 'byte-goto (cdr lap1)))
1724 (when (memq (car lap1) byte-goto-always-pop-ops)
1725 (setq lap (delq lap0 lap)))
1726 (setcar lap1 'byte-goto)))
1727 (setq keep-going t))
1728 ;;
1729 ;; varref-X varref-X --> varref-X dup
1730 ;; varref-X [dup ...] varref-X --> varref-X [dup ...] dup
1731 ;; stackref-X [dup ...] stackref-X+N --> stackref-X [dup ...] dup
1732 ;; We don't optimize the const-X variations on this here,
1733 ;; because that would inhibit some goto optimizations; we
1734 ;; optimize the const-X case after all other optimizations.
1735 ;;
1736 ((and (memq (car lap0) '(byte-varref byte-stack-ref))
1737 (progn
1738 (setq tmp (cdr rest))
1739 (setq tmp2 0)
1740 (while (eq (car (car tmp)) 'byte-dup)
1741 (setq tmp2 (1+ tmp2))
1742 (setq tmp (cdr tmp)))
1743 t)
1744 (eq (if (eq 'byte-stack-ref (car lap0))
1745 (+ tmp2 1 (cdr lap0))
1746 (cdr lap0))
1747 (cdr (car tmp)))
1748 (eq (car lap0) (car (car tmp))))
1749 (if (memq byte-optimize-log '(t byte))
1750 (let ((str ""))
1751 (setq tmp2 (cdr rest))
1752 (while (not (eq tmp tmp2))
1753 (setq tmp2 (cdr tmp2)
1754 str (concat str " dup")))
1755 (byte-compile-log-lap " %s%s %s\t-->\t%s%s dup"
1756 lap0 str lap0 lap0 str)))
1757 (setq keep-going t)
1758 (setcar (car tmp) 'byte-dup)
1759 (setcdr (car tmp) 0)
1760 (setq rest tmp))
1761 ;;
1762 ;; TAG1: TAG2: --> TAG1: <deleted>
1763 ;; (and other references to TAG2 are replaced with TAG1)
1764 ;;
1765 ((and (eq (car lap0) 'TAG)
1766 (eq (car lap1) 'TAG))
1767 (and (memq byte-optimize-log '(t byte))
1768 (byte-compile-log " adjacent tags %d and %d merged"
1769 (nth 1 lap1) (nth 1 lap0)))
1770 (setq tmp3 lap)
1771 (while (setq tmp2 (rassq lap0 tmp3))
1772 (setcdr tmp2 lap1)
1773 (setq tmp3 (cdr (memq tmp2 tmp3))))
1774 (setq lap (delq lap0 lap)
1775 keep-going t)
1776 ;; replace references to tag in jump tables, if any
1777 (dolist (table byte-compile-jump-tables)
1778 (maphash #'(lambda (value tag)
1779 (when (equal tag lap0)
1780 (puthash value lap1 table)))
1781 table)))
1782 ;;
1783 ;; unused-TAG: --> <deleted>
1784 ;;
1785 ((and (eq 'TAG (car lap0))
1786 (not (rassq lap0 lap))
1787 ;; make sure this tag isn't used in a jump-table
1788 (cl-loop for table in byte-compile-jump-tables
1789 when (member lap0 (hash-table-values table))
1790 return nil finally return t))
1791 (and (memq byte-optimize-log '(t byte))
1792 (byte-compile-log " unused tag %d removed" (nth 1 lap0)))
1793 (setq lap (delq lap0 lap)
1794 keep-going t))
1795 ;;
1796 ;; goto ... --> goto <delete until TAG or end>
1797 ;; return ... --> return <delete until TAG or end>
1798 ;; (unless a jump-table is being used, where deleting may affect
1799 ;; other valid case bodies)
1800 ;;
1801 ((and (memq (car lap0) '(byte-goto byte-return))
1802 (not (memq (car lap1) '(TAG nil)))
1803 ;; FIXME: Instead of deferring simply when jump-tables are
1804 ;; being used, keep a list of tags used for switch tags and
1805 ;; use them instead (see `byte-compile-inline-lapcode').
1806 (not byte-compile-jump-tables))
1807 (setq tmp rest)
1808 (let ((i 0)
1809 (opt-p (memq byte-optimize-log '(t lap)))
1810 str deleted)
1811 (while (and (setq tmp (cdr tmp))
1812 (not (eq 'TAG (car (car tmp)))))
1813 (if opt-p (setq deleted (cons (car tmp) deleted)
1814 str (concat str " %s")
1815 i (1+ i))))
1816 (if opt-p
1817 (let ((tagstr
1818 (if (eq 'TAG (car (car tmp)))
1819 (format "%d:" (car (cdr (car tmp))))
1820 (or (car tmp) ""))))
1821 (if (< i 6)
1822 (apply 'byte-compile-log-lap-1
1823 (concat " %s" str
1824 " %s\t-->\t%s <deleted> %s")
1825 lap0
1826 (nconc (nreverse deleted)
1827 (list tagstr lap0 tagstr)))
1828 (byte-compile-log-lap
1829 " %s <%d unreachable op%s> %s\t-->\t%s <deleted> %s"
1830 lap0 i (if (= i 1) "" "s")
1831 tagstr lap0 tagstr))))
1832 (rplacd rest tmp))
1833 (setq keep-going t))
1834 ;;
1835 ;; <safe-op> unbind --> unbind <safe-op>
1836 ;; (this may enable other optimizations.)
1837 ;;
1838 ((and (eq 'byte-unbind (car lap1))
1839 (memq (car lap0) byte-after-unbind-ops))
1840 (byte-compile-log-lap " %s %s\t-->\t%s %s" lap0 lap1 lap1 lap0)
1841 (setcar rest lap1)
1842 (setcar (cdr rest) lap0)
1843 (setq keep-going t))
1844 ;;
1845 ;; varbind-X unbind-N --> discard unbind-(N-1)
1846 ;; save-excursion unbind-N --> unbind-(N-1)
1847 ;; save-restriction unbind-N --> unbind-(N-1)
1848 ;;
1849 ((and (eq 'byte-unbind (car lap1))
1850 (memq (car lap0) '(byte-varbind byte-save-excursion
1851 byte-save-restriction))
1852 (< 0 (cdr lap1)))
1853 (if (zerop (setcdr lap1 (1- (cdr lap1))))
1854 (delq lap1 rest))
1855 (if (eq (car lap0) 'byte-varbind)
1856 (setcar rest (cons 'byte-discard 0))
1857 (setq lap (delq lap0 lap)))
1858 (byte-compile-log-lap " %s %s\t-->\t%s %s"
1859 lap0 (cons (car lap1) (1+ (cdr lap1)))
1860 (if (eq (car lap0) 'byte-varbind)
1861 (car rest)
1862 (car (cdr rest)))
1863 (if (and (/= 0 (cdr lap1))
1864 (eq (car lap0) 'byte-varbind))
1865 (car (cdr rest))
1866 ""))
1867 (setq keep-going t))
1868 ;;
1869 ;; goto*-X ... X: goto-Y --> goto*-Y
1870 ;; goto-X ... X: return --> return
1871 ;;
1872 ((and (memq (car lap0) byte-goto-ops)
1873 (memq (car (setq tmp (nth 1 (memq (cdr lap0) lap))))
1874 '(byte-goto byte-return)))
1875 (cond ((and (not (eq tmp lap0))
1876 (or (eq (car lap0) 'byte-goto)
1877 (eq (car tmp) 'byte-goto)))
1878 (byte-compile-log-lap " %s [%s]\t-->\t%s"
1879 (car lap0) tmp tmp)
1880 (if (eq (car tmp) 'byte-return)
1881 (setcar lap0 'byte-return))
1882 (setcdr lap0 (cdr tmp))
1883 (setq keep-going t))))
1884 ;;
1885 ;; goto-*-else-pop X ... X: goto-if-* --> whatever
1886 ;; goto-*-else-pop X ... X: discard --> whatever
1887 ;;
1888 ((and (memq (car lap0) '(byte-goto-if-nil-else-pop
1889 byte-goto-if-not-nil-else-pop))
1890 (memq (car (car (setq tmp (cdr (memq (cdr lap0) lap)))))
1891 (eval-when-compile
1892 (cons 'byte-discard byte-conditional-ops)))
1893 (not (eq lap0 (car tmp))))
1894 (setq tmp2 (car tmp))
1895 (setq tmp3 (assq (car lap0) '((byte-goto-if-nil-else-pop
1896 byte-goto-if-nil)
1897 (byte-goto-if-not-nil-else-pop
1898 byte-goto-if-not-nil))))
1899 (if (memq (car tmp2) tmp3)
1900 (progn (setcar lap0 (car tmp2))
1901 (setcdr lap0 (cdr tmp2))
1902 (byte-compile-log-lap " %s-else-pop [%s]\t-->\t%s"
1903 (car lap0) tmp2 lap0))
1904 ;; Get rid of the -else-pop's and jump one step further.
1905 (or (eq 'TAG (car (nth 1 tmp)))
1906 (setcdr tmp (cons (byte-compile-make-tag)
1907 (cdr tmp))))
1908 (byte-compile-log-lap " %s [%s]\t-->\t%s <skip>"
1909 (car lap0) tmp2 (nth 1 tmp3))
1910 (setcar lap0 (nth 1 tmp3))
1911 (setcdr lap0 (nth 1 tmp)))
1912 (setq keep-going t))
1913 ;;
1914 ;; const goto-X ... X: goto-if-* --> whatever
1915 ;; const goto-X ... X: discard --> whatever
1916 ;;
1917 ((and (eq (car lap0) 'byte-constant)
1918 (eq (car lap1) 'byte-goto)
1919 (memq (car (car (setq tmp (cdr (memq (cdr lap1) lap)))))
1920 (eval-when-compile
1921 (cons 'byte-discard byte-conditional-ops)))
1922 (not (eq lap1 (car tmp))))
1923 (setq tmp2 (car tmp))
1924 (cond ((when (consp (cdr lap0))
1925 (memq (car tmp2)
1926 (if (null (car (cdr lap0)))
1927 '(byte-goto-if-nil byte-goto-if-nil-else-pop)
1928 '(byte-goto-if-not-nil
1929 byte-goto-if-not-nil-else-pop))))
1930 (byte-compile-log-lap " %s goto [%s]\t-->\t%s %s"
1931 lap0 tmp2 lap0 tmp2)
1932 (setcar lap1 (car tmp2))
1933 (setcdr lap1 (cdr tmp2))
1934 ;; Let next step fix the (const,goto-if*) sequence.
1935 (setq rest (cons nil rest))
1936 (setq keep-going t))
1937 ((or (consp (cdr lap0))
1938 (eq (car tmp2) 'byte-discard))
1939 ;; Jump one step further
1940 (byte-compile-log-lap
1941 " %s goto [%s]\t-->\t<deleted> goto <skip>"
1942 lap0 tmp2)
1905 (or (eq 'TAG (car (nth 1 tmp))) 1943 (or (eq 'TAG (car (nth 1 tmp)))
1906 (setcdr tmp (cons (byte-compile-make-tag) 1944 (setcdr tmp (cons (byte-compile-make-tag)
1907 (cdr tmp)))) 1945 (cdr tmp))))
1908 (byte-compile-log-lap " %s [%s]\t-->\t%s <skip>" 1946 (setcdr lap1 (car (cdr tmp)))
1909 (car lap0) tmp2 (nth 1 tmp3)) 1947 (setq lap (delq lap0 lap))
1910 (setcar lap0 (nth 1 tmp3)) 1948 (setq keep-going t))))
1911 (setcdr lap0 (nth 1 tmp))) 1949 ;;
1912 (setq keep-going t)) 1950 ;; X: varref-Y ... varset-Y goto-X -->
1913 ;; 1951 ;; X: varref-Y Z: ... dup varset-Y goto-Z
1914 ;; const goto-X ... X: goto-if-* --> whatever 1952 ;; (varset-X goto-BACK, BACK: varref-X --> copy the varref down.)
1915 ;; const goto-X ... X: discard --> whatever 1953 ;; (This is so usual for while loops that it is worth handling).
1916 ;; 1954 ;;
1917 ((and (eq (car lap0) 'byte-constant) 1955 ;; Here again, we could do it for stack-ref/stack-set, but
1918 (eq (car lap1) 'byte-goto) 1956 ;; that's replacing a stack-ref-Y with a stack-ref-0, which
1919 (memq (car (car (setq tmp (cdr (memq (cdr lap1) lap))))) 1957 ;; is a very minor improvement (if any), at the cost of
1920 (eval-when-compile 1958 ;; more stack use and more byte-code. Let's not do it.
1921 (cons 'byte-discard byte-conditional-ops))) 1959 ;;
1922 (not (eq lap1 (car tmp)))) 1960 ((and (eq (car lap1) 'byte-varset)
1923 (setq tmp2 (car tmp)) 1961 (eq (car lap2) 'byte-goto)
1924 (cond ((when (consp (cdr lap0)) 1962 (not (memq (cdr lap2) rest)) ;Backwards jump
1925 (memq (car tmp2) 1963 (eq (car (car (setq tmp (cdr (memq (cdr lap2) lap)))))
1926 (if (null (car (cdr lap0))) 1964 'byte-varref)
1927 '(byte-goto-if-nil byte-goto-if-nil-else-pop) 1965 (eq (cdr (car tmp)) (cdr lap1))
1928 '(byte-goto-if-not-nil 1966 (not (memq (car (cdr lap1)) byte-boolean-vars)))
1929 byte-goto-if-not-nil-else-pop)))) 1967 ;;(byte-compile-log-lap " Pulled %s to end of loop" (car tmp))
1930 (byte-compile-log-lap " %s goto [%s]\t-->\t%s %s" 1968 (let ((newtag (byte-compile-make-tag)))
1931 lap0 tmp2 lap0 tmp2) 1969 (byte-compile-log-lap
1932 (setcar lap1 (car tmp2)) 1970 " %s: %s ... %s %s\t-->\t%s: %s %s: ... %s %s %s"
1933 (setcdr lap1 (cdr tmp2)) 1971 (nth 1 (cdr lap2)) (car tmp)
1934 ;; Let next step fix the (const,goto-if*) sequence. 1972 lap1 lap2
1935 (setq rest (cons nil rest)) 1973 (nth 1 (cdr lap2)) (car tmp)
1936 (setq keep-going t)) 1974 (nth 1 newtag) 'byte-dup lap1
1937 ((or (consp (cdr lap0)) 1975 (cons 'byte-goto newtag)
1938 (eq (car tmp2) 'byte-discard)) 1976 )
1939 ;; Jump one step further 1977 (setcdr rest (cons (cons 'byte-dup 0) (cdr rest)))
1940 (byte-compile-log-lap 1978 (setcdr tmp (cons (setcdr lap2 newtag) (cdr tmp))))
1941 " %s goto [%s]\t-->\t<deleted> goto <skip>" 1979 (setq add-depth 1)
1942 lap0 tmp2) 1980 (setq keep-going t))
1943 (or (eq 'TAG (car (nth 1 tmp))) 1981 ;;
1944 (setcdr tmp (cons (byte-compile-make-tag) 1982 ;; goto-X Y: ... X: goto-if*-Y --> goto-if-not-*-X+1 Y:
1945 (cdr tmp)))) 1983 ;; (This can pull the loop test to the end of the loop)
1946 (setcdr lap1 (car (cdr tmp))) 1984 ;;
1947 (setq lap (delq lap0 lap)) 1985 ((and (eq (car lap0) 'byte-goto)
1948 (setq keep-going t)))) 1986 (eq (car lap1) 'TAG)
1949 ;; 1987 (eq lap1
1950 ;; X: varref-Y ... varset-Y goto-X --> 1988 (cdr (car (setq tmp (cdr (memq (cdr lap0) lap))))))
1951 ;; X: varref-Y Z: ... dup varset-Y goto-Z 1989 (memq (car (car tmp))
1952 ;; (varset-X goto-BACK, BACK: varref-X --> copy the varref down.) 1990 '(byte-goto byte-goto-if-nil byte-goto-if-not-nil
1953 ;; (This is so usual for while loops that it is worth handling). 1991 byte-goto-if-nil-else-pop)))
1954 ;; 1992 ;; (byte-compile-log-lap " %s %s, %s %s --> moved conditional"
1955 ;; Here again, we could do it for stack-ref/stack-set, but 1993 ;; lap0 lap1 (cdr lap0) (car tmp))
1956 ;; that's replacing a stack-ref-Y with a stack-ref-0, which 1994 (let ((newtag (byte-compile-make-tag)))
1957 ;; is a very minor improvement (if any), at the cost of 1995 (byte-compile-log-lap
1958 ;; more stack use and more byte-code. Let's not do it. 1996 "%s %s: ... %s: %s\t-->\t%s ... %s:"
1959 ;; 1997 lap0 (nth 1 lap1) (nth 1 (cdr lap0)) (car tmp)
1960 ((and (eq (car lap1) 'byte-varset) 1998 (cons (cdr (assq (car (car tmp))
1961 (eq (car lap2) 'byte-goto) 1999 '((byte-goto-if-nil . byte-goto-if-not-nil)
1962 (not (memq (cdr lap2) rest)) ;Backwards jump 2000 (byte-goto-if-not-nil . byte-goto-if-nil)
1963 (eq (car (car (setq tmp (cdr (memq (cdr lap2) lap))))) 2001 (byte-goto-if-nil-else-pop .
1964 'byte-varref) 2002 byte-goto-if-not-nil-else-pop)
1965 (eq (cdr (car tmp)) (cdr lap1)) 2003 (byte-goto-if-not-nil-else-pop .
1966 (not (memq (car (cdr lap1)) byte-boolean-vars))) 2004 byte-goto-if-nil-else-pop))))
1967 ;;(byte-compile-log-lap " Pulled %s to end of loop" (car tmp)) 2005 newtag)
1968 (let ((newtag (byte-compile-make-tag))) 2006
1969 (byte-compile-log-lap 2007 (nth 1 newtag)
1970 " %s: %s ... %s %s\t-->\t%s: %s %s: ... %s %s %s" 2008 )
1971 (nth 1 (cdr lap2)) (car tmp) 2009 (setcdr tmp (cons (setcdr lap0 newtag) (cdr tmp)))
1972 lap1 lap2 2010 (if (eq (car (car tmp)) 'byte-goto-if-nil-else-pop)
1973 (nth 1 (cdr lap2)) (car tmp) 2011 ;; We can handle this case but not the -if-not-nil case,
1974 (nth 1 newtag) 'byte-dup lap1 2012 ;; because we won't know which non-nil constant to push.
1975 (cons 'byte-goto newtag) 2013 (setcdr rest (cons (cons 'byte-constant
1976 ) 2014 (byte-compile-get-constant nil))
1977 (setcdr rest (cons (cons 'byte-dup 0) (cdr rest))) 2015 (cdr rest))))
1978 (setcdr tmp (cons (setcdr lap2 newtag) (cdr tmp)))) 2016 (setcar lap0 (nth 1 (memq (car (car tmp))
1979 (setq add-depth 1) 2017 '(byte-goto-if-nil-else-pop
1980 (setq keep-going t)) 2018 byte-goto-if-not-nil
1981 ;; 2019 byte-goto-if-nil
1982 ;; goto-X Y: ... X: goto-if*-Y --> goto-if-not-*-X+1 Y: 2020 byte-goto-if-not-nil
1983 ;; (This can pull the loop test to the end of the loop) 2021 byte-goto byte-goto))))
1984 ;; 2022 )
1985 ((and (eq (car lap0) 'byte-goto) 2023 (setq keep-going t))
1986 (eq (car lap1) 'TAG) 2024 )
1987 (eq lap1
1988 (cdr (car (setq tmp (cdr (memq (cdr lap0) lap))))))
1989 (memq (car (car tmp))
1990 '(byte-goto byte-goto-if-nil byte-goto-if-not-nil
1991 byte-goto-if-nil-else-pop)))
1992;; (byte-compile-log-lap " %s %s, %s %s --> moved conditional"
1993;; lap0 lap1 (cdr lap0) (car tmp))
1994 (let ((newtag (byte-compile-make-tag)))
1995 (byte-compile-log-lap
1996 "%s %s: ... %s: %s\t-->\t%s ... %s:"
1997 lap0 (nth 1 lap1) (nth 1 (cdr lap0)) (car tmp)
1998 (cons (cdr (assq (car (car tmp))
1999 '((byte-goto-if-nil . byte-goto-if-not-nil)
2000 (byte-goto-if-not-nil . byte-goto-if-nil)
2001 (byte-goto-if-nil-else-pop .
2002 byte-goto-if-not-nil-else-pop)
2003 (byte-goto-if-not-nil-else-pop .
2004 byte-goto-if-nil-else-pop))))
2005 newtag)
2006
2007 (nth 1 newtag)
2008 )
2009 (setcdr tmp (cons (setcdr lap0 newtag) (cdr tmp)))
2010 (if (eq (car (car tmp)) 'byte-goto-if-nil-else-pop)
2011 ;; We can handle this case but not the -if-not-nil case,
2012 ;; because we won't know which non-nil constant to push.
2013 (setcdr rest (cons (cons 'byte-constant
2014 (byte-compile-get-constant nil))
2015 (cdr rest))))
2016 (setcar lap0 (nth 1 (memq (car (car tmp))
2017 '(byte-goto-if-nil-else-pop
2018 byte-goto-if-not-nil
2019 byte-goto-if-nil
2020 byte-goto-if-not-nil
2021 byte-goto byte-goto))))
2022 )
2023 (setq keep-going t))
2024 )
2025 (setq rest (cdr rest))) 2025 (setq rest (cdr rest)))
2026 ) 2026 )
2027 ;; Cleanup stage: 2027 ;; Cleanup stage:
generated by cgit v1.2.1 (git 2.18.0) at 2026-02-25 14:27:58 +0000