Mercurial > hg > xemacs-beta

comparison lisp/byte-optimize.el @ 1297:6c21360a544b

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
[xemacs-hg @ 2003-02-14 11:50:36 by ben] bytecomp patch commit byte-optimize.el: Review carefully and sync up to 20.7 except for areas as noted. Fixes problem with JDE compilation.
author ben
date Fri, 14 Feb 2003 11:50:36 +0000
parents 1638aacf421d
children f35582fa32a9
comparison
equal deleted inserted replaced
1296:87084e8445a7 1297:6c21360a544b
22 ;; You should have received a copy of the GNU General Public License 22 ;; You should have received a copy of the GNU General Public License
23 ;; along with XEmacs; see the file COPYING. If not, write to the 23 ;; along with XEmacs; see the file COPYING. If not, write to the
24 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, 24 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
25 ;; Boston, MA 02111-1307, USA. 25 ;; Boston, MA 02111-1307, USA.
26 26
27 ;;; Synched up with: FSF 20.7. 27 ;;; Synched up with: FSF 20.7 except where marked.
28 ;;; [[ Synched up with: FSF 20.7. ]]
29 ;;; DO NOT PUT IN AN INVALID SYNC MESSAGE WHEN YOU DO A PARTIAL SYNC. --ben
30
31 ;; BEGIN SYNC WITH 20.7.
28 32
29 ;;; Commentary: 33 ;;; Commentary:
30 34
31 ;; ======================================================================== 35 ;; ========================================================================
32 ;; "No matter how hard you try, you can't make a racehorse out of a pig. 36 ;; "No matter how hard you try, you can't make a racehorse out of a pig.
290 (list 'byte-code 294 (list 'byte-code
291 (compiled-function-instructions fn) 295 (compiled-function-instructions fn)
292 (compiled-function-constants fn) 296 (compiled-function-constants fn)
293 (compiled-function-stack-depth fn))) 297 (compiled-function-stack-depth fn)))
294 (cdr form))) 298 (cdr form)))
295 (if (not (eq (car fn) 'lambda)) (error "%s is not a lambda" name)) 299 (if (eq (car-safe fn) 'lambda)
296 (cons fn (cdr form))))))) 300 (cons fn (cdr form))
301 ;; Give up on inlining.
302 form))))))
297 303
298 ;;; ((lambda ...) ...) 304 ;;; ((lambda ...) ...)
299 ;;; 305 ;;;
300 (defun byte-compile-unfold-lambda (form &optional name) 306 (defun byte-compile-unfold-lambda (form &optional name)
301 (or name (setq name "anonymous lambda")) 307 (or name (setq name "anonymous lambda"))
349 (progn 355 (progn
350 (or (eq values 'too-few) 356 (or (eq values 'too-few)
351 (byte-compile-warn 357 (byte-compile-warn
352 "attempt to open-code %s with too many arguments" name)) 358 "attempt to open-code %s with too many arguments" name))
353 form) 359 form)
360 (setq body (mapcar 'byte-optimize-form body))
354 (let ((newform 361 (let ((newform
355 (if bindings 362 (if bindings
356 (cons 'let (cons (nreverse bindings) body)) 363 (cons 'let (cons (nreverse bindings) body))
357 (cons 'progn body)))) 364 (cons 'progn body))))
358 (byte-compile-log " %s\t==>\t%s" form newform) 365 (byte-compile-log " %s\t==>\t%s" form newform)
518 ((not (eq form 525 ((not (eq form
519 (setq form (macroexpand form 526 (setq form (macroexpand form
520 byte-compile-macro-environment)))) 527 byte-compile-macro-environment))))
521 (byte-optimize-form form for-effect)) 528 (byte-optimize-form form for-effect))
522 529
530 ;; Support compiler macros as in cl.el.
531 ((and (fboundp 'compiler-macroexpand)
532 (symbolp (car-safe form))
533 (get (car-safe form) 'cl-compiler-macro)
534 (not (eq form
535 (setq form (compiler-macroexpand form)))))
536 (byte-optimize-form form for-effect))
537
523 ((not (symbolp fn)) 538 ((not (symbolp fn))
524 (or (eq 'mocklisp (car-safe fn)) ; ha! 539 (or (eq 'mocklisp (car-safe fn)) ; ha!
525 (byte-compile-warn "%s is a malformed function" 540 (byte-compile-warn "%s is a malformed function"
526 (prin1-to-string fn))) 541 (prin1-to-string fn)))
527 form) 542 form)
565 (setq opt (get (car form) 'byte-optimizer))) 580 (setq opt (get (car form) 'byte-optimizer)))
566 (not (eq form (setq new (funcall opt form))))) 581 (not (eq form (setq new (funcall opt form)))))
567 (progn 582 (progn
568 ;; (if (equal form new) (error "bogus optimizer -- %s" opt)) 583 ;; (if (equal form new) (error "bogus optimizer -- %s" opt))
569 (byte-compile-log " %s\t==>\t%s" form new) 584 (byte-compile-log " %s\t==>\t%s" form new)
570 (byte-optimize-form new for-effect)) 585 (setq new (byte-optimize-form new for-effect))
586 new)
571 form))) 587 form)))
572 588
573 589
574 (defun byte-optimize-body (forms all-for-effect) 590 (defun byte-optimize-body (forms all-for-effect)
575 ;; Optimize the cdr of a progn or implicit progn; `forms' is a list of 591 ;; Optimize the cdr of a progn or implicit progn; `forms' is a list of
697 (setq form orig) 713 (setq form orig)
698 (setq form (nconc (delq nil form) 714 (setq form (nconc (delq nil form)
699 (list (apply fun (nreverse constants))))))))) 715 (list (apply fun (nreverse constants)))))))))
700 form)) 716 form))
701 717
718 ;; END SYNC WITH 20.7.
719
702 ;;; It is not safe to optimize calls to arithmetic ops with one arg 720 ;;; It is not safe to optimize calls to arithmetic ops with one arg
703 ;;; away entirely (actually, it would be safe if we know the sole arg 721 ;;; away entirely (actually, it would be safe if we know the sole arg
704 ;;; is not a marker or if it appears in other arithmetic). 722 ;;; is not a marker or if it appears in other arithmetic).
705 723
706 ;;; But this degree of paranoia is normally unjustified, so optimize unless 724 ;;; But this degree of paranoia is normally unjustified, so optimize unless
759 ((eq (nth 1 form) 0) 777 ((eq (nth 1 form) 0)
760 (append '(progn) (cdr (cdr form)) '(0))) 778 (append '(progn) (cdr (cdr form)) '(0)))
761 779
762 ;; We don't have to check for divide-by-zero because `/' does. 780 ;; We don't have to check for divide-by-zero because `/' does.
763 (t (byte-optimize-predicate form))))) 781 (t (byte-optimize-predicate form)))))
782
783 ;; BEGIN SYNC WITH 20.7.
764 784
765 (defun byte-optimize-logmumble (form) 785 (defun byte-optimize-logmumble (form)
766 (setq form (byte-optimize-delay-constants-math form 1 (car form))) 786 (setq form (byte-optimize-delay-constants-math form 1 (car form)))
767 (byte-optimize-predicate 787 (byte-optimize-predicate
768 (cond ((memq 0 form) 788 (cond ((memq 0 form)
943 rest (setcdr (memq (car rest) form) nil)))) 963 rest (setcdr (memq (car rest) form) nil))))
944 (if (cdr (cdr form)) 964 (if (cdr (cdr form))
945 (byte-optimize-predicate form) 965 (byte-optimize-predicate form)
946 (nth 1 form)))) 966 (nth 1 form))))
947 967
968 ;; END SYNC WITH 20.7.
969
948 ;;; For the byte optimizer, `cond' is just overly sweet syntactic sugar. 970 ;;; For the byte optimizer, `cond' is just overly sweet syntactic sugar.
949 ;;; So we rewrite (cond ...) in terms of `if' and `or', 971 ;;; So we rewrite (cond ...) in terms of `if' and `or',
950 ;;; which are easier to optimize. 972 ;;; which are easier to optimize.
951 (defun byte-optimize-cond (form) 973 (defun byte-optimize-cond (form)
952 (byte-optimize-cond-1 (cdr form))) 974 (byte-optimize-cond-1 (cdr form)))
960 (1 `(or ,(nth 0 (car clauses)))) 982 (1 `(or ,(nth 0 (car clauses))))
961 (2 `(if ,(nth 0 (car clauses)) ,(nth 1 (car clauses)))) 983 (2 `(if ,(nth 0 (car clauses)) ,(nth 1 (car clauses))))
962 (t `(if ,(nth 0 (car clauses)) (progn ,@(cdr (car clauses)))))) 984 (t `(if ,(nth 0 (car clauses)) (progn ,@(cdr (car clauses))))))
963 (when (cdr clauses) (list (byte-optimize-cond-1 (cdr clauses)))))) 985 (when (cdr clauses) (list (byte-optimize-cond-1 (cdr clauses))))))
964 (t (error "malformed cond clause %s" (car clauses))))) 986 (t (error "malformed cond clause %s" (car clauses)))))
987
988 ;; BEGIN SYNC WITH 20.7.
965 989
966 (defun byte-optimize-if (form) 990 (defun byte-optimize-if (form)
967 ;; (if <true-constant> <then> <else...>) ==> <then> 991 ;; (if <true-constant> <then> <else...>) ==> <then>
968 ;; (if <false-constant> <then> <else...>) ==> (progn <else...>) 992 ;; (if <false-constant> <then> <else...>) ==> (progn <else...>)
969 ;; (if <test> nil <else...>) ==> (if (not <test>) (progn <else...>)) 993 ;; (if <test> nil <else...>) ==> (if (not <test>) (progn <else...>))
1353 (cons (cons offset 1377 (cons (cons offset
1354 (byte-compile-make-tag)) 1378 (byte-compile-make-tag))
1355 tags))))))) 1379 tags)))))))
1356 ((cond ((eq op 'byte-constant2) (setq op 'byte-constant) t) 1380 ((cond ((eq op 'byte-constant2) (setq op 'byte-constant) t)
1357 ((memq op byte-constref-ops))) 1381 ((memq op byte-constref-ops)))
1358 (setq tmp (aref constvec offset) 1382 (setq tmp (if (>= offset (length constvec))
1383 (list 'out-of-range offset)
1384 (aref constvec offset))
1359 offset (if (eq op 'byte-constant) 1385 offset (if (eq op 'byte-constant)
1360 (byte-compile-get-constant tmp) 1386 (byte-compile-get-constant tmp)
1361 (or (assq tmp byte-compile-variables) 1387 (or (assq tmp byte-compile-variables)
1362 (car (setq byte-compile-variables 1388 (car (setq byte-compile-variables
1363 (cons (list tmp) 1389 (cons (list tmp)
1465 ;;; hard to maintain. Such a list is not necessary under XEmacs, 1491 ;;; hard to maintain. Such a list is not necessary under XEmacs,
1466 ;;; where we can use `built-in-variable-type' to query for boolean 1492 ;;; where we can use `built-in-variable-type' to query for boolean
1467 ;;; variables. 1493 ;;; variables.
1468 1494
1469 ;(defconst byte-boolean-vars 1495 ;(defconst byte-boolean-vars
1470 ; '(abbrev-all-caps purify-flag find-file-compare-truenames 1496 ; ...)
1471 ; find-file-use-truenames delete-auto-save-files byte-metering-on
1472 ; x-seppuku-on-epipe zmacs-regions zmacs-region-active-p
1473 ; zmacs-region-stays atomic-extent-goto-char-p
1474 ; suppress-early-error-handler-backtrace noninteractive
1475 ; inhibit-early-packages inhibit-autoloads debug-paths
1476 ; inhibit-site-lisp debug-on-quit debug-on-next-call
1477 ; modifier-keys-are-sticky x-allow-sendevents
1478 ; mswindows-dynamic-frame-resize focus-follows-mouse
1479 ; inhibit-input-event-recording enable-multibyte-characters
1480 ; disable-auto-save-when-buffer-shrinks
1481 ; allow-deletion-of-last-visible-frame indent-tabs-mode
1482 ; load-in-progress load-warn-when-source-newer
1483 ; load-warn-when-source-only load-ignore-elc-files
1484 ; load-force-doc-strings fail-on-bucky-bit-character-escapes
1485 ; popup-menu-titles menubar-show-keybindings completion-ignore-case
1486 ; canna-empty-info canna-through-info canna-underline
1487 ; canna-inhibit-hankakukana enable-multibyte-characters
1488 ; re-short-flag x-handle-non-fully-specified-fonts
1489 ; print-escape-newlines print-readably delete-exited-processes
1490 ; windowed-process-io visible-bell no-redraw-on-reenter
1491 ; cursor-in-echo-area inhibit-warning-display
1492 ; column-number-start-at-one parse-sexp-ignore-comments
1493 ; words-include-escapes scroll-on-clipped-lines)
1494 ; "DEFVAR_BOOL variables. Giving these any non-nil value sets them to t.
1495 ;If this does not enumerate all DEFVAR_BOOL variables, the byte-optimizer
1496 ;may generate incorrect code.")
1497 1497
1498 (defun byte-optimize-lapcode (lap &optional for-effect) 1498 (defun byte-optimize-lapcode (lap &optional for-effect)
1499 "Simple peephole optimizer. LAP is both modified and returned." 1499 "Simple peephole optimizer. LAP is both modified and returned."
1500 (let (lap0 1500 (let (lap0
1501 lap1 1501 lap1
1952 variable-frequency (make-hash-table :test 'eq)) 1952 variable-frequency (make-hash-table :test 'eq))
1953 (setq rest lap) 1953 (setq rest lap)
1954 (while rest 1954 (while rest
1955 (setq lap0 (car rest) 1955 (setq lap0 (car rest)
1956 lap1 (nth 1 rest)) 1956 lap1 (nth 1 rest))
1957 (case (car lap0) 1957 (if (memq (car lap0) byte-constref-ops)
1958 ((byte-varref byte-varset byte-varbind) 1958 (if (not (eq (car lap0) 'byte-constant))
1959 (incf (gethash (cdr lap0) variable-frequency 0)) 1959 (progn
1960 (unless (memq (cdr lap0) byte-compile-variables) 1960 (incf (gethash (cdr lap0) variable-frequency 0))
1961 (push (cdr lap0) byte-compile-variables))) 1961 (or (memq (cdr lap0) byte-compile-variables)
1962 ((byte-constant) 1962 (setq byte-compile-variables
1963 (unless (memq (cdr lap0) byte-compile-constants) 1963 (cons (cdr lap0) byte-compile-variables))))
1964 (push (cdr lap0) byte-compile-constants)))) 1964 (or (memq (cdr lap0) byte-compile-constants)
1965 (setq byte-compile-constants (cons (cdr lap0)
1966 byte-compile-constants)))))
1965 (cond (;; 1967 (cond (;;
1966 ;; const-C varset-X const-C --> const-C dup varset-X 1968 ;; const-C varset-X const-C --> const-C dup varset-X
1967 ;; const-C varbind-X const-C --> const-C dup varbind-X 1969 ;; const-C varbind-X const-C --> const-C dup varbind-X
1968 ;; 1970 ;;
1969 (and (eq (car lap0) 'byte-constant) 1971 (and (eq (car lap0) 'byte-constant)
2045 ;; Inserted some more than necessary, to speed it up. 2047 ;; Inserted some more than necessary, to speed it up.
2046 byte-optimize-form-code-walker 2048 byte-optimize-form-code-walker
2047 byte-optimize-lapcode)))) 2049 byte-optimize-lapcode))))
2048 nil) 2050 nil)
2049 2051
2052 ;; END SYNC WITH 20.7.
2053
2050 ;;; byte-optimize.el ends here 2054 ;;; byte-optimize.el ends here