X-Git-Url: https://git.hcoop.net/bpt/emacs.git/blobdiff_plain/70f4194508a971101163af3e4dc02438a83b68c9..dfb4dab1a22926befbef30fb9f2105f515374e46:/lisp/emacs-lisp/byte-opt.el diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el index 4097ada0bd..c34c88cb72 100644 --- a/lisp/emacs-lisp/byte-opt.el +++ b/lisp/emacs-lisp/byte-opt.el @@ -1,7 +1,7 @@ ;;; byte-opt.el --- the optimization passes of the emacs-lisp byte compiler ;; Copyright (C) 1991, 1994, 2000, 2001, 2002, 2003, 2004, -;; 2005, 2006, 2007 Free Software Foundation, Inc. +;; 2005, 2006, 2007, 2008 Free Software Foundation, Inc. ;; Author: Jamie Zawinski ;; Hallvard Furuseth @@ -10,10 +10,10 @@ ;; This file is part of GNU Emacs. -;; GNU Emacs is free software; you can redistribute it and/or modify +;; GNU Emacs is free software: you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 3, or (at your option) -;; any later version. +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of @@ -21,9 +21,7 @@ ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;; Boston, MA 02110-1301, USA. +;; along with GNU Emacs. If not, see . ;;; Commentary: @@ -185,6 +183,7 @@ ;;; Code: (require 'bytecomp) +(eval-when-compile (require 'cl)) (defun byte-compile-log-lap-1 (format &rest args) (if (aref byte-code-vector 0) @@ -276,6 +275,8 @@ ;; Isn't it an error for `string' not to be unibyte?? --stef (if (fboundp 'string-as-unibyte) (setq string (string-as-unibyte string))) + ;; `byte-compile-splice-in-already-compiled-code' + ;; takes care of inlining the body. (cons `(lambda ,(aref fn 0) (byte-code ,string ,(aref fn 2) ,(aref fn 3))) (cdr form))) @@ -380,7 +381,9 @@ form)) ((or (byte-code-function-p fn) (eq 'lambda (car-safe fn))) - (byte-compile-unfold-lambda form)) + (byte-optimize-form-code-walker + (byte-compile-unfold-lambda form) + for-effect)) ((memq fn '(let let*)) ;; recursively enter the optimizer for the bindings and body ;; of a let or let*. This for depth-firstness: forms that @@ -625,13 +628,32 @@ ;; ;; It is now safe to optimize code such that it introduces new bindings. -;; I'd like this to be a defsubst, but let's not be self-referential... -(defmacro byte-compile-trueconstp (form) - ;; Returns non-nil if FORM is a non-nil constant. - `(cond ((consp ,form) (eq (car ,form) 'quote)) - ((not (symbolp ,form))) - ((eq ,form t)) - ((keywordp ,form)))) +(defsubst byte-compile-trueconstp (form) + "Return non-nil if FORM always evaluates to a non-nil value." + (while (eq (car-safe form) 'progn) + (setq form (car (last (cdr form))))) + (cond ((consp form) + (case (car form) + (quote (cadr form)) + ;; Can't use recursion in a defsubst. + ;; (progn (byte-compile-trueconstp (car (last (cdr form))))) + )) + ((not (symbolp form))) + ((eq form t)) + ((keywordp form)))) + +(defsubst byte-compile-nilconstp (form) + "Return non-nil if FORM always evaluates to a nil value." + (while (eq (car-safe form) 'progn) + (setq form (car (last (cdr form))))) + (cond ((consp form) + (case (car form) + (quote (null (cadr form))) + ;; Can't use recursion in a defsubst. + ;; (progn (byte-compile-nilconstp (car (last (cdr form))))) + )) + ((not (symbolp form)) nil) + ((null form)))) ;; If the function is being called with constant numeric args, ;; evaluate as much as possible at compile-time. This optimizer @@ -990,17 +1012,17 @@ (setq rest form) (while (setq rest (cdr rest)) (cond ((byte-compile-trueconstp (car-safe (car rest))) - (cond ((eq rest (cdr form)) - (setq form - (if (cdr (car rest)) - (if (cdr (cdr (car rest))) - (cons 'progn (cdr (car rest))) - (nth 1 (car rest))) - (car (car rest))))) + ;; This branch will always be taken: kill the subsequent ones. + (cond ((eq rest (cdr form)) ;First branch of `cond'. + (setq form `(progn ,@(car rest)))) ((cdr rest) (setq form (copy-sequence form)) (setcdr (memq (car rest) form) nil))) - (setq rest nil))))) + (setq rest nil)) + ((and (consp (car rest)) + (byte-compile-nilconstp (caar rest))) + ;; This branch will never be taken: kill its body. + (setcdr (car rest) nil))))) ;; ;; Turn (cond (( )) ... ) into (or (cond ... )) (if (eq 'cond (car-safe form)) @@ -1031,11 +1053,9 @@ (byte-optimize-if `(if ,(car (last clause)) ,@(nthcdr 2 form))))))) ((byte-compile-trueconstp clause) - (nth 2 form)) - ((null clause) - (if (nthcdr 4 form) - (cons 'progn (nthcdr 3 form)) - (nth 3 form))) + `(progn ,clause ,(nth 2 form))) + ((byte-compile-nilconstp clause) + `(progn ,clause ,@(nthcdr 3 form))) ((nth 2 form) (if (equal '(nil) (nthcdr 3 form)) (list 'if clause (nth 2 form)) @@ -1197,8 +1217,9 @@ char-equal char-to-string char-width compare-strings concat coordinates-in-window-p copy-alist copy-sequence copy-marker cos count-lines + decode-char decode-time default-boundp default-value documentation downcase - elt exp expt encode-time error-message-string + elt encode-char exp expt encode-time error-message-string fboundp fceiling featurep ffloor file-directory-p file-exists-p file-locked-p file-name-absolute-p file-newer-than-file-p file-readable-p file-symlink-p file-writable-p @@ -1209,7 +1230,7 @@ int-to-string intern-soft keymap-parent length local-variable-if-set-p local-variable-p log log10 logand - logb logior lognot logxor lsh + logb logior lognot logxor lsh langinfo make-list make-string make-symbol marker-buffer max member memq min mod multibyte-char-to-unibyte next-window nth nthcdr number-to-string @@ -1221,6 +1242,7 @@ string-to-int string-to-number substring sxhash symbol-function symbol-name symbol-plist symbol-value string-make-unibyte string-make-multibyte string-as-multibyte string-as-unibyte + string-to-multibyte tan truncate unibyte-char-to-multibyte upcase user-full-name user-login-name user-original-login-name user-variable-p @@ -1232,7 +1254,8 @@ '(arrayp atom bobp bolp bool-vector-p buffer-end buffer-list buffer-size buffer-string bufferp - car-safe case-table-p cdr-safe char-or-string-p commandp cons consp + car-safe case-table-p cdr-safe char-or-string-p characterp + charsetp commandp cons consp current-buffer current-global-map current-indentation current-local-map current-minor-mode-maps current-time current-time-string current-time-zone @@ -1244,11 +1267,13 @@ invocation-directory invocation-name keymapp line-beginning-position line-end-position list listp - make-marker mark mark-marker markerp memory-limit minibuffer-window + make-marker mark mark-marker markerp max-char + memory-limit minibuffer-window mouse-movement-p natnump nlistp not null number-or-marker-p numberp one-window-p overlayp - point point-marker point-min point-max preceding-char processp + point point-marker point-min point-max preceding-char primary-charset + processp recent-keys recursion-depth safe-length selected-frame selected-window sequencep standard-case-table standard-syntax-table stringp subrp symbolp