/[emacs]/emacs/lisp/emacs-lisp/byte-opt.el
ViewVC logotype

Diff of /emacs/lisp/emacs-lisp/byte-opt.el

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.64.2.2 by miles, Sat Aug 17 14:47:25 2002 UTC revision 1.64.2.3 by miles, Sun Aug 18 15:57:18 2002 UTC
# Line 1335  Line 1335 
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))
# Line 1391  Line 1398 
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
# Line 1400  Line 1407 
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.
# Line 1438  Line 1445 
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
# Line 1454  Line 1463 
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.
# Line 1467  Line 1502 
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                ;;                ;;
# Line 1499  Line 1534 
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
# Line 1507  Line 1543 
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)
# Line 1542  Line 1582 
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
# Line 1567  Line 1608 
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:
# Line 1583  Line 1625 
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                ;;                ;;
# Line 1600  Line 1643 
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
# Line 1616  Line 1658 
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))
# Line 1635  Line 1677 
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)
# Line 1702  Line 1745 
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)
# Line 1804  Line 1848 
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
# Line 1874  Line 1920 
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
# Line 1935  Line 1988 
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)))

Legend:
Removed from v.1.64.2.2  
changed lines
  Added in v.1.64.2.3

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26