1335 |
(setq offset (or endtag (setq endtag (byte-compile-make-tag))) |
(setq offset (or endtag (setq endtag (byte-compile-make-tag))) |
1336 |
op 'byte-goto))) |
op 'byte-goto))) |
1337 |
((eq op 'byte-stack-set2) |
((eq op 'byte-stack-set2) |
1338 |
(setq op 'byte-stack-set))) |
(setq op 'byte-stack-set)) |
1339 |
|
((and (eq op 'byte-discardN) (>= offset #x80)) |
1340 |
|
;; The top bit of the operand for byte-discardN is a flag, |
1341 |
|
;; saying whether the top-of-stack is preserved. In |
1342 |
|
;; lapcode, we represent this by using a different opcode |
1343 |
|
;; (with the flag removed from the operand). |
1344 |
|
(setq op 'byte-discardN-preserve-tos) |
1345 |
|
(setq offset (- offset #x80)))) |
1346 |
;; lap = ( [ (pc . (op . arg)) ]* ) |
;; lap = ( [ (pc . (op . arg)) ]* ) |
1347 |
(setq lap (cons (cons optr (cons op (or offset 0))) |
(setq lap (cons (cons optr (cons op (or offset 0))) |
1348 |
lap)) |
lap)) |
1398 |
byte-cdr-safe byte-cons byte-list1 byte-list2 byte-point byte-point-max |
byte-cdr-safe byte-cons byte-list1 byte-list2 byte-point byte-point-max |
1399 |
byte-point-min byte-following-char byte-preceding-char |
byte-point-min byte-following-char byte-preceding-char |
1400 |
byte-current-column byte-eolp byte-eobp byte-bolp byte-bobp |
byte-current-column byte-eolp byte-eobp byte-bolp byte-bobp |
1401 |
byte-current-buffer byte-interactive-p)) |
byte-current-buffer byte-interactive-p byte-stack-ref)) |
1402 |
|
|
1403 |
(defconst byte-compile-side-effect-free-ops |
(defconst byte-compile-side-effect-free-ops |
1404 |
(nconc |
(nconc |
1407 |
byte-eqlsign byte-gtr byte-lss byte-leq byte-geq byte-diff byte-negate |
byte-eqlsign byte-gtr byte-lss byte-leq byte-geq byte-diff byte-negate |
1408 |
byte-plus byte-max byte-min byte-mult byte-char-after byte-char-syntax |
byte-plus byte-max byte-min byte-mult byte-char-after byte-char-syntax |
1409 |
byte-buffer-substring byte-string= byte-string< byte-nthcdr byte-elt |
byte-buffer-substring byte-string= byte-string< byte-nthcdr byte-elt |
1410 |
byte-member byte-assq byte-quo byte-rem) |
byte-member byte-assq byte-quo byte-rem byte-vec-ref) |
1411 |
byte-compile-side-effect-and-error-free-ops)) |
byte-compile-side-effect-and-error-free-ops)) |
1412 |
|
|
1413 |
;;; This crock is because of the way DEFVAR_BOOL variables work. |
;;; This crock is because of the way DEFVAR_BOOL variables work. |
1445 |
(let (lap0 |
(let (lap0 |
1446 |
lap1 |
lap1 |
1447 |
lap2 |
lap2 |
1448 |
|
stack-adjust |
1449 |
|
(stack-depth 0) |
1450 |
(keep-going 'first-time) |
(keep-going 'first-time) |
1451 |
(add-depth 0) |
(add-depth 0) |
1452 |
rest tmp tmp2 tmp3 |
rest tmp tmp2 tmp3 |
1463 |
lap1 (nth 1 rest) |
lap1 (nth 1 rest) |
1464 |
lap2 (nth 2 rest)) |
lap2 (nth 2 rest)) |
1465 |
|
|
1466 |
|
(cond ((eq (car lap0) 'TAG) |
1467 |
|
;; A tag can encode the expected stack depth. |
1468 |
|
(when (cddr lap0) |
1469 |
|
;; First, check to see if our notion of the current stack |
1470 |
|
;; depth agrees with this tag. We don't check at the |
1471 |
|
;; beginning of the function, because the presence of |
1472 |
|
;; lexical arguments means the first tag will have a |
1473 |
|
;; non-zero offset. |
1474 |
|
(when (and (not (eq rest lap)) ; not at first insn |
1475 |
|
stack-depth ; not just after a goto |
1476 |
|
(not (= (cddr lap0) stack-depth))) |
1477 |
|
(error "Compiler error: optimizer is confused about stack-depth: |
1478 |
|
%s != %s at lapcode %s" (cddr lap0) stack-depth lap0)) |
1479 |
|
;; Now set out current depth from this tag |
1480 |
|
(setq stack-depth (cddr lap0))) |
1481 |
|
(setq stack-adjust 0)) |
1482 |
|
((memq (car lap0) '(byte-goto byte-return)) |
1483 |
|
;; These insns leave us in an unknown state |
1484 |
|
(setq stack-adjust nil)) |
1485 |
|
(t |
1486 |
|
;; stack-adjust will be added to stack-depth at the end of the |
1487 |
|
;; loop, so any code that modifies the isntruction sequence must |
1488 |
|
;; adjust this too. |
1489 |
|
(setq stack-adjust |
1490 |
|
(byte-compile-stack-adjustment (car lap0) (cdr lap0))))) |
1491 |
|
|
1492 |
;; You may notice that sequences like "dup varset discard" are |
;; You may notice that sequences like "dup varset discard" are |
1493 |
;; optimized but sequences like "dup varset TAG1: discard" are not. |
;; optimized but sequences like "dup varset TAG1: discard" are not. |
1494 |
;; You may be tempted to change this; resist that temptation. |
;; You may be tempted to change this; resist that temptation. |
1502 |
((and (eq 'byte-discard (car lap1)) |
((and (eq 'byte-discard (car lap1)) |
1503 |
(memq (car lap0) side-effect-free)) |
(memq (car lap0) side-effect-free)) |
1504 |
(setq keep-going t) |
(setq keep-going t) |
|
(setq tmp (aref byte-stack+-info (symbol-value (car lap0)))) |
|
1505 |
(setq rest (cdr rest)) |
(setq rest (cdr rest)) |
1506 |
(cond ((= tmp 1) |
(cond ((= stack-adjust 1) |
1507 |
(byte-compile-log-lap |
(byte-compile-log-lap |
1508 |
" %s discard\t-->\t<deleted>" lap0) |
" %s discard\t-->\t<deleted>" lap0) |
1509 |
(setq lap (delq lap0 (delq lap1 lap)))) |
(setq lap (delq lap0 (delq lap1 lap)))) |
1510 |
((= tmp 0) |
((= stack-adjust 0) |
1511 |
(byte-compile-log-lap |
(byte-compile-log-lap |
1512 |
" %s discard\t-->\t<deleted> discard" lap0) |
" %s discard\t-->\t<deleted> discard" lap0) |
1513 |
(setq lap (delq lap0 lap))) |
(setq lap (delq lap0 lap))) |
1514 |
((= tmp -1) |
((= stack-adjust -1) |
1515 |
(byte-compile-log-lap |
(byte-compile-log-lap |
1516 |
" %s discard\t-->\tdiscard discard" lap0) |
" %s discard\t-->\tdiscard discard" lap0) |
1517 |
(setcar lap0 'byte-discard) |
(setcar lap0 'byte-discard) |
1518 |
(setcdr lap0 0)) |
(setcdr lap0 0)) |
1519 |
((error "Optimizer error: too much on the stack")))) |
((error "Optimizer error: too much on the stack"))) |
1520 |
|
(setq stack-adjust (1- stack-adjust))) |
1521 |
;; |
;; |
1522 |
;; goto*-X X: --> X: |
;; goto*-X X: --> X: |
1523 |
;; |
;; |
1534 |
(byte-compile-log " (goto %s) %s:\t-->\t%s %s:" |
(byte-compile-log " (goto %s) %s:\t-->\t%s %s:" |
1535 |
(nth 1 lap1) (nth 1 lap1) |
(nth 1 lap1) (nth 1 lap1) |
1536 |
tmp (nth 1 lap1))) |
tmp (nth 1 lap1))) |
1537 |
(setq keep-going t)) |
(setq keep-going t |
1538 |
|
stack-adjust 0)) |
1539 |
;; |
;; |
1540 |
;; varset-X varref-X --> dup varset-X |
;; varset-X varref-X --> dup varset-X |
1541 |
;; varbind-X varref-X --> dup varbind-X |
;; varbind-X varref-X --> dup varbind-X |
1543 |
;; const/dup varbind-X varref-X --> const/dup varbind-X const/dup |
;; const/dup varbind-X varref-X --> const/dup varbind-X const/dup |
1544 |
;; The latter two can enable other optimizations. |
;; The latter two can enable other optimizations. |
1545 |
;; |
;; |
1546 |
((and (eq 'byte-varref (car lap2)) |
((or (and (eq 'byte-varref (car lap2)) |
1547 |
(eq (cdr lap1) (cdr lap2)) |
(eq (cdr lap1) (cdr lap2)) |
1548 |
(memq (car lap1) '(byte-varset byte-varbind))) |
(memq (car lap1) '(byte-varset byte-varbind))) |
1549 |
(if (and (setq tmp (memq (car (cdr lap2)) byte-boolean-vars)) |
(and (eq (car lap2) 'byte-stack-ref) |
1550 |
|
(eq (car lap1) 'byte-stack-set) |
1551 |
|
(eq (cdr lap1) (cdr lap2)))) |
1552 |
|
(if (and (eq 'byte-varref (car lap2)) |
1553 |
|
(setq tmp (memq (car (cdr lap2)) byte-boolean-vars)) |
1554 |
(not (eq (car lap0) 'byte-constant))) |
(not (eq (car lap0) 'byte-constant))) |
1555 |
nil |
nil |
1556 |
(setq keep-going t) |
(setq keep-going t) |
1582 |
;; |
;; |
1583 |
((and (eq 'byte-dup (car lap0)) |
((and (eq 'byte-dup (car lap0)) |
1584 |
(eq 'byte-discard (car lap2)) |
(eq 'byte-discard (car lap2)) |
1585 |
(memq (car lap1) '(byte-varset byte-varbind))) |
(memq (car lap1) '(byte-varset byte-varbind byte-stack-set byte-vec-set))) |
1586 |
(byte-compile-log-lap " dup %s discard\t-->\t%s" lap1 lap1) |
(byte-compile-log-lap " dup %s discard\t-->\t%s" lap1 lap1) |
1587 |
(setq keep-going t |
(setq keep-going t |
1588 |
rest (cdr rest)) |
rest (cdr rest) |
1589 |
|
stack-adjust -1) |
1590 |
(setq lap (delq lap0 (delq lap2 lap)))) |
(setq lap (delq lap0 (delq lap2 lap)))) |
1591 |
;; |
;; |
1592 |
;; not goto-X-if-nil --> goto-X-if-non-nil |
;; not goto-X-if-nil --> goto-X-if-non-nil |
1608 |
'byte-goto-if-not-nil |
'byte-goto-if-not-nil |
1609 |
'byte-goto-if-nil)) |
'byte-goto-if-nil)) |
1610 |
(setq lap (delq lap0 lap)) |
(setq lap (delq lap0 lap)) |
1611 |
(setq keep-going t)) |
(setq keep-going t |
1612 |
|
stack-adjust 0)) |
1613 |
;; |
;; |
1614 |
;; goto-X-if-nil goto-Y X: --> goto-Y-if-non-nil X: |
;; goto-X-if-nil goto-Y X: --> goto-Y-if-non-nil X: |
1615 |
;; goto-X-if-non-nil goto-Y X: --> goto-Y-if-nil X: |
;; goto-X-if-non-nil goto-Y X: --> goto-Y-if-nil X: |
1625 |
(byte-compile-log-lap " %s %s %s:\t-->\t%s %s:" |
(byte-compile-log-lap " %s %s %s:\t-->\t%s %s:" |
1626 |
lap0 lap1 lap2 |
lap0 lap1 lap2 |
1627 |
(cons inverse (cdr lap1)) lap2) |
(cons inverse (cdr lap1)) lap2) |
1628 |
(setq lap (delq lap0 lap)) |
(setq lap (delq lap0 lap) |
1629 |
|
stack-adjust 0) |
1630 |
(setcar lap1 inverse) |
(setcar lap1 inverse) |
1631 |
(setq keep-going t))) |
(setq keep-going t))) |
1632 |
;; |
;; |
1643 |
(setq rest (cdr rest) |
(setq rest (cdr rest) |
1644 |
lap (delq lap0 (delq lap1 lap)))) |
lap (delq lap0 (delq lap1 lap)))) |
1645 |
(t |
(t |
1646 |
(if (memq (car lap1) byte-goto-always-pop-ops) |
(byte-compile-log-lap " %s %s\t-->\t%s" |
1647 |
(progn |
lap0 lap1 |
1648 |
(byte-compile-log-lap " %s %s\t-->\t%s" |
(cons 'byte-goto (cdr lap1))) |
1649 |
lap0 lap1 (cons 'byte-goto (cdr lap1))) |
(when (memq (car lap1) byte-goto-always-pop-ops) |
1650 |
(setq lap (delq lap0 lap))) |
(setq lap (delq lap0 lap))) |
|
(byte-compile-log-lap " %s %s\t-->\t%s" lap0 lap1 |
|
|
(cons 'byte-goto (cdr lap1)))) |
|
1651 |
(setcar lap1 'byte-goto))) |
(setcar lap1 'byte-goto))) |
1652 |
(setq keep-going t)) |
(setq keep-going t |
1653 |
|
stack-adjust 0)) |
1654 |
;; |
;; |
1655 |
;; varref-X varref-X --> varref-X dup |
;; varref-X varref-X --> varref-X dup |
1656 |
;; varref-X [dup ...] varref-X --> varref-X [dup ...] dup |
;; varref-X [dup ...] varref-X --> varref-X [dup ...] dup |
1658 |
;; because that would inhibit some goto optimizations; we |
;; because that would inhibit some goto optimizations; we |
1659 |
;; optimize the const-X case after all other optimizations. |
;; optimize the const-X case after all other optimizations. |
1660 |
;; |
;; |
1661 |
((and (eq 'byte-varref (car lap0)) |
((and (memq (car lap0) '(byte-varref byte-stack-ref)) |
1662 |
(progn |
(progn |
1663 |
(setq tmp (cdr rest)) |
(setq tmp (cdr rest) tmp2 0) |
1664 |
(while (eq (car (car tmp)) 'byte-dup) |
(while (eq (car (car tmp)) 'byte-dup) |
1665 |
(setq tmp (cdr tmp))) |
(setq tmp (cdr tmp) tmp2 (1+ tmp2))) |
1666 |
t) |
t) |
1667 |
(eq (cdr lap0) (cdr (car tmp))) |
(eq (car lap0) (car (car tmp))) |
1668 |
(eq 'byte-varref (car (car tmp)))) |
(eq (cdr lap0) (cdr (car tmp)))) |
1669 |
(if (memq byte-optimize-log '(t byte)) |
(if (memq byte-optimize-log '(t byte)) |
1670 |
(let ((str "")) |
(let ((str "")) |
1671 |
(setq tmp2 (cdr rest)) |
(setq tmp2 (cdr rest)) |
1677 |
(setq keep-going t) |
(setq keep-going t) |
1678 |
(setcar (car tmp) 'byte-dup) |
(setcar (car tmp) 'byte-dup) |
1679 |
(setcdr (car tmp) 0) |
(setcdr (car tmp) 0) |
1680 |
(setq rest tmp)) |
(setq rest tmp |
1681 |
|
stack-adjust (+ 2 tmp2))) |
1682 |
;; |
;; |
1683 |
;; TAG1: TAG2: --> TAG1: <deleted> |
;; TAG1: TAG2: --> TAG1: <deleted> |
1684 |
;; (and other references to TAG2 are replaced with TAG1) |
;; (and other references to TAG2 are replaced with TAG1) |
1745 |
(byte-compile-log-lap " %s %s\t-->\t%s %s" lap0 lap1 lap1 lap0) |
(byte-compile-log-lap " %s %s\t-->\t%s %s" lap0 lap1 lap1 lap0) |
1746 |
(setcar rest lap1) |
(setcar rest lap1) |
1747 |
(setcar (cdr rest) lap0) |
(setcar (cdr rest) lap0) |
1748 |
(setq keep-going t)) |
(setq keep-going t |
1749 |
|
stack-adjust 0)) |
1750 |
;; |
;; |
1751 |
;; varbind-X unbind-N --> discard unbind-(N-1) |
;; varbind-X unbind-N --> discard unbind-(N-1) |
1752 |
;; save-excursion unbind-N --> unbind-(N-1) |
;; save-excursion unbind-N --> unbind-(N-1) |
1848 |
(cdr tmp)))) |
(cdr tmp)))) |
1849 |
(setcdr lap1 (car (cdr tmp))) |
(setcdr lap1 (car (cdr tmp))) |
1850 |
(setq lap (delq lap0 lap)))) |
(setq lap (delq lap0 lap)))) |
1851 |
(setq keep-going t)) |
(setq keep-going t |
1852 |
|
stack-adjust 0)) |
1853 |
;; |
;; |
1854 |
;; X: varref-Y ... varset-Y goto-X --> |
;; X: varref-Y ... varset-Y goto-X --> |
1855 |
;; X: varref-Y Z: ... dup varset-Y goto-Z |
;; X: varref-Y Z: ... dup varset-Y goto-Z |
1856 |
;; (varset-X goto-BACK, BACK: varref-X --> copy the varref down.) |
;; (varset-X goto-BACK, BACK: varref-X --> copy the varref down.) |
1857 |
;; (This is so usual for while loops that it is worth handling). |
;; (This is so usual for while loops that it is worth handling). |
1858 |
;; |
;; |
1859 |
((and (eq (car lap1) 'byte-varset) |
((and (memq (car lap1) '(byte-varset byte-stack-set)) |
1860 |
(eq (car lap2) 'byte-goto) |
(eq (car lap2) 'byte-goto) |
1861 |
(not (memq (cdr lap2) rest)) ;Backwards jump |
(not (memq (cdr lap2) rest)) ;Backwards jump |
1862 |
(eq (car (car (setq tmp (cdr (memq (cdr lap2) lap))))) |
(eq (car (car (setq tmp (cdr (memq (cdr lap2) lap))))) |
1863 |
'byte-varref) |
(if (eq (car lap1) 'byte-varset) 'byte-varref 'byte-stack-ref)) |
1864 |
(eq (cdr (car tmp)) (cdr lap1)) |
(eq (cdr (car tmp)) (cdr lap1)) |
1865 |
(not (memq (car (cdr lap1)) byte-boolean-vars))) |
(not (and (eq (car lap1) 'byte-varref) |
1866 |
|
(memq (car (cdr lap1)) byte-boolean-vars)))) |
1867 |
;;(byte-compile-log-lap " Pulled %s to end of loop" (car tmp)) |
;;(byte-compile-log-lap " Pulled %s to end of loop" (car tmp)) |
1868 |
(let ((newtag (byte-compile-make-tag))) |
(let ((newtag (byte-compile-make-tag))) |
1869 |
(byte-compile-log-lap |
(byte-compile-log-lap |
1920 |
byte-goto-if-not-nil |
byte-goto-if-not-nil |
1921 |
byte-goto byte-goto)))) |
byte-goto byte-goto)))) |
1922 |
) |
) |
1923 |
(setq keep-going t)) |
(setq keep-going t |
1924 |
|
stack-adjust (and (not (eq (car lap0) 'byte-goto)) -1))) |
1925 |
) |
) |
1926 |
|
|
1927 |
|
(if (and stack-depth stack-adjust) |
1928 |
|
(setq stack-depth (+ stack-depth stack-adjust)) |
1929 |
|
(setq stack-depth nil)) |
1930 |
|
|
1931 |
(setq rest (cdr rest))) |
(setq rest (cdr rest))) |
1932 |
) |
) |
1933 |
|
|
1934 |
;; Cleanup stage: |
;; Cleanup stage: |
1935 |
;; Rebuild byte-compile-constants / byte-compile-variables. |
;; Rebuild byte-compile-constants / byte-compile-variables. |
1936 |
;; Simple optimizations that would inhibit other optimizations if they |
;; Simple optimizations that would inhibit other optimizations if they |
1988 |
(byte-compile-log-lap " %s %s\t-->\t%s" lap0 lap1 |
(byte-compile-log-lap " %s %s\t-->\t%s" lap0 lap1 |
1989 |
(cons 'byte-unbind |
(cons 'byte-unbind |
1990 |
(+ (cdr lap0) (cdr lap1)))) |
(+ (cdr lap0) (cdr lap1)))) |
|
(setq keep-going t) |
|
1991 |
(setq lap (delq lap0 lap)) |
(setq lap (delq lap0 lap)) |
1992 |
(setcdr lap1 (+ (cdr lap1) (cdr lap0)))) |
(setcdr lap1 (+ (cdr lap1) (cdr lap0)))) |
1993 |
|
;; ;; |
1994 |
|
;; ;; [(stack-set-M [discard ...]) ...] --> discardN-preserve-tos-(...) |
1995 |
|
;; ;; |
1996 |
|
;; ((and (memq (car lap0) '(byte-discard byte-discardN)) |
1997 |
|
;; (memq (car lap1) '(byte-discard byte-discardN))) |
1998 |
|
;; (setq tmp rest) |
1999 |
|
;; (while (memq (car tmp) '(byte-discard byte-discardN)) |
2000 |
|
;; (setq tmp2 (+ tmp2 (if (eq (car rest) 'byte-discard) 1 (cdar tmp)))) |
2001 |
|
;; (setq tmp (cdr tmp))) |
2002 |
|
;; (setcar lap0 'byte-discardN) |
2003 |
|
;; (setcdr lap0 tmp2) |
2004 |
|
;; (setcdr rest tmp)) |
2005 |
|
;; ;; |
2006 |
|
;; ;; [discard/discardN-M ...] --> discardN-(M+...) |
2007 |
|
;; ;; |
2008 |
|
;; ((and (memq (car lap0) '(byte-discard byte-discardN)) |
2009 |
|
;; (memq (car lap1) '(byte-discard byte-discardN))) |
2010 |
|
;; (setq tmp rest) |
2011 |
|
;; (while (memq (car tmp) '(byte-discard byte-discardN)) |
2012 |
|
;; (setq tmp2 (+ tmp2 (if (eq (car rest) 'byte-discard) 1 (cdar tmp)))) |
2013 |
|
;; (setq tmp (cdr tmp))) |
2014 |
|
;; (setcar lap0 'byte-discardN) |
2015 |
|
;; (setcdr lap0 tmp2) |
2016 |
|
;; (setcdr rest tmp)) |
2017 |
|
;; ;; |
2018 |
|
;; ;; [discardN-preserve-tos-M ...] --> discardN-preserve-tos-(M+...) |
2019 |
|
;; ;; |
2020 |
|
;; ((and (eq (car lap0) 'byte-discardN-preserve-tos) |
2021 |
|
;; (eq (car lap1) 'byte-discardN-preserve-tos)) |
2022 |
|
;; (setq tmp rest) |
2023 |
|
;; (while (eq (car tmp) 'byte-discardN-preserve-tos) |
2024 |
|
;; (setq tmp2 (+ tmp2 (cdar tmp))) |
2025 |
|
;; (setq tmp (cdr tmp))) |
2026 |
|
;; (setcar lap0 'byte-discardN-preserve-tos) |
2027 |
|
;; (setcdr lap0 tmp2) |
2028 |
|
;; (setcdr rest tmp)) |
2029 |
) |
) |
2030 |
(setq rest (cdr rest))) |
(setq rest (cdr rest))) |
2031 |
(setq byte-compile-maxdepth (+ byte-compile-maxdepth add-depth))) |
(setq byte-compile-maxdepth (+ byte-compile-maxdepth add-depth))) |