xemacs-beta: lisp/byte-optimize.el comparison

comparison lisp/byte-optimize.el @ 398:74fd4e045ea6 r21-2-29

Import from CVS: tag r21-2-29

author	cvs
date	Mon, 13 Aug 2007 11:13:30 +0200
parents	8626e4521993
children	a86b2b5e0111

comparison

equal deleted inserted replaced

-:f4aeb21a5bad
+:74fd4e045ea6
 ;;; byte-optimize.el --- the optimization passes of the emacs-lisp byte compiler.
 ;;; Copyright (c) 1991, 1994 Free Software Foundation, Inc.
-;; Author: Jamie Zawinski <jwz@netscape.com>
+;; Author: Jamie Zawinski <jwz@jwz.org>
 ;;	Hallvard Furuseth <hbf@ulrik.uio.no>
 ;; Keywords: internal
 ;; This file is part of XEmacs.
 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 ;; General Public License for more details.
 ;; You should have received a copy of the GNU General Public License
 ;; along with XEmacs; see the file COPYING.  If not, write to the
 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
 ;; Boston, MA 02111-1307, USA.
 ;;; Synched up with: FSF 19.30.
 ;; ========================================================================
 ;; "No matter how hard you try, you can't make a racehorse out of a pig.
 ;; You can, however, make a faster pig."
 ;;
 ;; Or, to put it another way, the emacs byte compiler is a VW Bug.  This code
 ;; makes it be a VW Bug with fuel injection and a turbocharger...  You're
 ;; still not going to make it go faster than 70 mph, but it might be easier
 ;; to get it there.
 ;;
 ;; TO DO:
 ;; others?
 ;;
 ;; Simple defsubsts often produce forms like
 ;;    (let ((v1 (f1)) (v2 (f2)) ...)
 ;;       (FN v1 v2 ...))
 ;; It would be nice if we could optimize this to
 ;;    (FN (f1) (f2) ...)
 ;; but we can't unless FN is dynamically-safe (it might be dynamically
 ;; referring to the bindings that the lambda arglist established.)
 ;; One of the uncountable lossages introduced by dynamic scope...
 ;;
 ;; Maybe there should be a control-structure that says "turn on
 ;; fast-and-loose type-assumptive optimizations here."  Then when
 ;; we see a form like (car foo) we can from then on assume that
 ;; the variable foo is of type cons, and optimize based on that.
 ;; But, this won't win much because of (you guessed it) dynamic
 ;; scope.  Anything down the stack could change the value.
 ;; (Another reason it doesn't work is that it is perfectly valid
 ;; to call car with a null argument.)  A better approach might
 ;; be to allow type-specification of the form
 ;;   (put 'foo 'arg-types '(float (list integer) dynamic))
 ;;           (funcall fn (car list))
 ;;           (tail-map fn (cdr list)))))
 ;;
 ;; However, if there was even a single let-binding around the COND,
 ;; it could not be byte-compiled, because there would be an "unbind"
 ;; byte-op between the final "call" and "return."  Adding a
 ;; Bunbind_all byteop would fix this.
 ;;
 ;;   (defun foo (x y z) ... (foo a b c))
 ;;   ... (const foo) (varref a) (varref b) (varref c) (call 3) END: (return)
 ;;   ... (varref a) (varbind x) (varref b) (varbind y) (varref c) (varbind z) (goto 0) END: (unbind-all) (return)
 ;; overflow.  I don't believe there is any way around this without lexical
 ;; scope.
 ;;
 ;; Wouldn't it be nice if Emacs Lisp had lexical scope.
 ;;
 ;; Idea: the form (lexical-scope) in a file means that the file may be
 ;; compiled lexically.  This proclamation is file-local.  Then, within
 ;; that file, "let" would establish lexical bindings, and "let-dynamic"
 ;; would do things the old way.  (Or we could use CL "declare" forms.)
 ;; We'd have to notice defvars and defconsts, since those variables should
 ;; always be dynamic, and attempting to do a lexical binding of them
 ;; should simply do a dynamic binding instead.
 ;; But!  We need to know about variables that were not necessarily defvarred
 ;; in the file being compiled (doing a boundp check isn't good enough.)
 ;; Fdefvar() would have to be modified to add something to the plist.
 ;;
 ;; A major disadvantage of this scheme is that the interpreter and compiler
 ;; would have different semantics for files compiled with (dynamic-scope).
 ;; Since this would be a file-local optimization, there would be no way to
 ;; modify the interpreter to obey this (unless the loader was hacked
 ;; in some grody way, but that's a really bad idea.)
 ;;
 ;; HA!  RMS removed the following paragraph from his version of
 ;; byte-optimize.el.
 ;;
 ;; Really the Right Thing is to make lexical scope the default across
 ;; the board, in the interpreter and compiler, and just FIX all of
 ;; the code that relies on dynamic scope of non-defvarred variables.
 ;; Other things to consider:
 ;; Associative math should recognize subcalls to identical function:
 ;;(disassemble #'(lambda (x) (cons (+ x 1) (- x 1))))
 ;; An awful lot of functions always return a non-nil value.  If they're
 ;; error free also they may act as true-constants.
 ;;(disassemble #'(lambda (x) (and (point) (foo))))
 ;; When
 ;;   - all but one arguments to a function are constant
 ;;   - the non-constant argument is an if-expression (cond-expression?)
 ;; then the outer function can be distributed.  If the guarding
 ;; condition is side-effect-free [assignment-free] then the other
 ;; arguments may be any expressions.  Since, however, the code size
 		    (cdr form)))
 	  (if (not (eq (car fn) 'lambda)) (error "%s is not a lambda" name))
 	  (cons fn (cdr form)))))))
 ;;; ((lambda ...) ...)
 ;;;
 (defun byte-compile-unfold-lambda (form &optional name)
 (or name (setq name "anonymous lambda"))
 (let ((lambda (car form))
 	(values (cdr form)))
 (if (compiled-function-p lambda)
 	  (progn
 	    (or (eq values 'too-few)
 		(byte-compile-warn
 		 "attempt to open-code %s with too many arguments" name))
 	    form)
 	(let ((newform
 	       (if bindings
 		   (cons 'let (cons (nreverse bindings) body))
 		 (cons 'progn body))))
 	  (byte-compile-log "  %s\t==>\t%s" form newform)
 	  newform)))))
 	  ((eq fn 'prog2)
 	   (cons 'prog2
 	     (cons (byte-optimize-form (nth 1 form) t)
 	       (cons (byte-optimize-form (nth 2 form) for-effect)
 		     (byte-optimize-body (cdr (cdr (cdr form))) t)))))
 	  ((memq fn '(save-excursion save-restriction save-current-buffer))
 	   ;; those subrs which have an implicit progn; it's not quite good
 	   ;; enough to treat these like normal function calls.
 	   ;; This can turn (save-excursion ...) into (save-excursion) which
 	   ;; will be optimized away in the lap-optimize pass.
 	   (cons fn (byte-optimize-body (cdr form) for-effect)))
 	  ((eq fn 'with-output-to-temp-buffer)
 	   ;; this is just like the above, except for the first argument.
 	   (cons fn
 	     (cons
 	      (byte-optimize-form (nth 1 form) nil)
 	      (byte-optimize-body (cdr (cdr form)) for-effect))))
 	  ((eq fn 'if)
 	   (cons fn
 	     (cons (byte-optimize-form (nth 1 form) nil)
 	       (cons
 		(byte-optimize-form (nth 2 form) for-effect)
 		(byte-optimize-body (nthcdr 3 form) for-effect)))))
 	  ((memq fn '(and or))  ; remember, and/or are control structures.
 	   ;; take forms off the back until we can't any more.
 	   ;; In the future it could conceivably be a problem that the
 	   ;; subexpressions of these forms are optimized in the reverse
 	   ;; order, but it's ok for now.
 	  ((eq fn 'interactive)
 	   (byte-compile-warn "misplaced interactive spec: %s"
 			      (prin1-to-string form))
 	   nil)
 	  ((memq fn '(defun defmacro function
 		      condition-case save-window-excursion))
 	   ;; These forms are compiled as constants or by breaking out
 	   ;; all the subexpressions and compiling them separately.
 	   form)
 	   ;; unwind-protect itself.  (The protected part is always for effect,
 	   ;; but that isn't handled properly yet.)
 	   (cons fn
 		 (cons (byte-optimize-form (nth 1 form) for-effect)
 		       (cdr (cdr form)))))
 	  ((eq fn 'catch)
 	   ;; the body of a catch is compiled (and thus optimized) as a
 	   ;; top-level form, so don't do it here.  The tag is never
 	   ;; for-effect.  The body should have the same for-effect status
 	   ;; as the catch form itself, but that isn't handled properly yet.
 	  ;; by the time that is reached.
 	  ((not (eq form
 		    (setq form (macroexpand form
 					    byte-compile-macro-environment))))
 	   (byte-optimize-form form for-effect))
 	  ((not (symbolp fn))
 	   (or (eq 'mocklisp (car-safe fn)) ; ha!
 	       (byte-compile-warn "%s is a malformed function"
 				  (prin1-to-string fn)))
 	   form)
 		      nil)))
 	   (byte-compile-log "  %s called for effect; deleted" fn)
 	   ;; appending a nil here might not be necessary, but it can't hurt.
 	   (byte-optimize-form
 	    (cons 'progn (append (cdr form) '(nil))) t))
 	  (t
 	   ;; Otherwise, no args can be considered to be for-effect,
 	   ;; even if the called function is for-effect, because we
 	   ;; don't know anything about that function.
 	   (cons fn (mapcar 'byte-optimize-form (cdr form)))))))
 	 ((not (symbolp ,form)))
 	 ((eq ,form t))
 	 ((keywordp ,form))))
 ;; If the function is being called with constant numeric args,
 ;; evaluate as much as possible at compile-time.  This optimizer
 ;; assumes that the function is associative, like + or *.
 (defun byte-optimize-associative-math (form)
 (let ((args nil)
 	(constants nil)
 	(rest (cdr form)))
 (defun byte-optimize-plus (form)
 (setq form (byte-optimize-delay-constants-math form 1 '+))
 (if (memq 0 form) (setq form (delq 0 (copy-sequence form))))
 ;;(setq form (byte-optimize-associative-two-args-math form))
-(cond ((null (cdr form))
+(case (length (cdr form))
-	 (condition-case ()
+((0)
-	     (eval form)
+(condition-case ()
-	   (error form)))
+	 (eval form)
+(error form)))
-	;; `add1' and `sub1' are a marginally fewer instructions
-	;; than `plus' and `minus', so use them when possible.
+;; `add1' and `sub1' are a marginally fewer instructions
-	((and (null (nthcdr 3 form))
+;; than `plus' and `minus', so use them when possible.
-	      (eq (nth 2 form) 1))
+((2)
-	 (list '1+ (nth 1 form)))	; (+ x 1)  -->  (1+ x)
+(cond
-	((and (null (nthcdr 3 form))
+((eq (nth 1 form)  1) `(1+ ,(nth 2 form))) ; (+ 1 x)   -->  (1+ x)
-	      (eq (nth 1 form) 1))
+((eq (nth 2 form)  1) `(1+ ,(nth 1 form))) ; (+ x 1)   -->  (1+ x)
-	 (list '1+ (nth 2 form)))	; (+ 1 x)  -->  (1+ x)
+((eq (nth 1 form) -1) `(1- ,(nth 2 form))) ; (+ -1 x)  -->  (1- x)
-	((and (null (nthcdr 3 form))
+((eq (nth 2 form) -1) `(1- ,(nth 1 form))) ; (+ x -1)  -->  (1- x)
-	      (eq (nth 2 form) -1))
+(t form)))
-	 (list '1- (nth 1 form)))	; (+ x -1)  -->  (1- x)
-	((and (null (nthcdr 3 form))
+;; It is not safe to delete the function entirely
-	      (eq (nth 1 form) -1))
+;; (actually, it would be safe if we know the sole arg
-	 (list '1- (nth 2 form)))	; (+ -1 x)  -->  (1- x)
+;; is not a marker).
+;;	((null (cdr (cdr form))) (nth 1 form))
-;;; It is not safe to delete the function entirely
+(t form)))
-;;; (actually, it would be safe if we know the sole arg
-;;; is not a marker).
-;;	((null (cdr (cdr form))) (nth 1 form))
-	(t form)))
 (defun byte-optimize-minus (form)
 ;; Put constants at the end, except the last constant.
 (setq form (byte-optimize-delay-constants-math form 2 '+))
 ;; Now only first and last element can be a number.
 		  (prog1 (setq form (delq 2 (copy-sequence form)))
 		    (while (not (symbolp (car (setq form (cdr form))))))
 		    (setcar form (list '+ (car form) (car form)))))
 		 (form))))))
-(defsubst byte-compile-butlast (form)
-(nreverse (cdr (reverse form))))
 (defun byte-optimize-divide (form)
 (setq form (byte-optimize-delay-constants-math form 2 '*))
 (let ((last (car (reverse (cdr (cdr form))))))
 (if (numberp last)
 	(cond ((= (length form) 3)
 			(condition-case nil
 			    (/ (nth 1 form) last)
 			  (error nil)))
 		   (setq form (list 'progn (/ (nth 1 form) last)))))
 	      ((= last 1)
-	       (setq form (byte-compile-butlast form)))
+	       (setq form (butlast form)))
 	      ((numberp (nth 1 form))
 	       (setq form (cons (car form)
 				(cons (/ (nth 1 form) last)
-				      (byte-compile-butlast (cdr (cdr form)))))
+				      (butlast (cdr (cdr form)))))
 		     last nil))))
 (cond
 ;;;	  ((null (cdr (cdr form)))
 ;;;	   (nth 1 form))
 	  ((eq (nth 1 form) 0)
 	   (append '(progn) (cdr (cdr form)) '(0)))
 	  ((eq last -1)
 	   (list '- (if (nthcdr 3 form)
-			(byte-compile-butlast form)
+			(butlast form)
 		      (nth 1 form))))
 	  (form))))
 (defun byte-optimize-logmumble (form)
 (setq form (byte-optimize-delay-constants-math form 1 (car form)))
 (put 'listp 'byte-optimizer 'byte-optimize-predicate)
 (put 'symbolp 'byte-optimizer 'byte-optimize-predicate)
 (put 'stringp 'byte-optimizer 'byte-optimize-predicate)
 (put 'string< 'byte-optimizer 'byte-optimize-predicate)
 (put 'string-lessp 'byte-optimizer 'byte-optimize-predicate)
+(put 'length 'byte-optimizer 'byte-optimize-predicate)
 (put 'logand 'byte-optimizer 'byte-optimize-logmumble)
 (put 'logior 'byte-optimizer 'byte-optimize-logmumble)
 (put 'logxor 'byte-optimizer 'byte-optimize-logmumble)
 (put 'lognot 'byte-optimizer 'byte-optimize-predicate)
 (put 'cdr 'byte-optimizer 'byte-optimize-predicate)
 (put 'car-safe 'byte-optimizer 'byte-optimize-predicate)
 (put 'cdr-safe 'byte-optimizer 'byte-optimize-predicate)
 ;; I'm not convinced that this is necessary.  Doesn't the optimizer loop
 ;; take care of this? - Jamie
 ;; I think this may some times be necessary to reduce eg. (quote 5) to 5,
 ;; so arithmetic optimizers recognize the numeric constant.  - Hallvard
 (put 'quote 'byte-optimizer 'byte-optimize-quote)
 (defun byte-optimize-quote (form)
 (put 'or    'byte-optimizer 'byte-optimize-or)
 (put 'cond  'byte-optimizer 'byte-optimize-cond)
 (put 'if    'byte-optimizer 'byte-optimize-if)
 (put 'while 'byte-optimizer 'byte-optimize-while)
+;; Remove any reason for avoiding `char-before'.
+(defun byte-optimize-char-before (form)
+`(char-after (1- ,(or (nth 1 form) '(point))) ,@(cdr (cdr form))))
+(put 'char-before 'byte-optimizer 'byte-optimize-char-before)
 ;; byte-compile-negation-optimizer lives in bytecomp.el
 ;(put '/= 'byte-optimizer 'byte-compile-negation-optimizer)
 (put 'atom 'byte-optimizer 'byte-compile-negation-optimizer)
 (put 'nlistp 'byte-optimizer 'byte-compile-negation-optimizer)
 (setq form (nth 2 form))
 (while (>= (setq count (1- count)) 0)
 	(setq form (list 'cdr form)))
 form)))
 ;;; enumerating those functions which need not be called if the returned
 ;;; value is not used.  That is, something like
 ;;;    (progn (list (something-with-side-effects) (yow))
 ;;;           (foo))
 ;;; may safely be turned into
 ;;;    (progn (progn (something-with-side-effects) (yow))
 	 ;;
 	 int-to-string
 	 length log log10 logand logb logior lognot logxor lsh
 	 marker-buffer max member memq min mod
 	 next-window nth nthcdr number-to-string
-	 parse-colon-path previous-window
+	 parse-colon-path plist-get previous-window
 	 radians-to-degrees rassq regexp-quote reverse round
 	 sin sqrt string< string= string-equal string-lessp string-to-char
 	 string-to-int string-to-number substring symbol-plist
 	 tan upcase user-variable-p vconcat
 	 ;; XEmacs change: window-edges -> window-pixel-edges
 	 ;; functions defined by cl
 	 oddp evenp plusp minusp
 	 abs expt signum last butlast ldiff
 	 pairlis gcd lcm
 	 isqrt floor* ceiling* truncate* round* mod* rem* subseq
-	 list-length get* getf
+	 list-length getf
 	 ))
 (side-effect-and-error-free-fns
 '(arrayp atom
 	 bobp bolp buffer-end buffer-list buffer-size buffer-string bufferp
 	 car-safe case-table-p cdr-safe char-or-string-p char-table-p
 byte-point-min byte-following-char byte-preceding-char
 byte-current-column byte-eolp byte-eobp byte-bolp byte-bobp
 byte-current-buffer byte-interactive-p))
 (defconst byte-compile-side-effect-free-ops
 (nconc
 '(byte-varref byte-nth byte-memq byte-car byte-cdr byte-length byte-aref
 byte-symbol-value byte-get byte-concat2 byte-concat3 byte-sub1 byte-add1
 byte-eqlsign byte-gtr byte-lss byte-leq byte-geq byte-diff byte-negate
 byte-plus byte-max byte-min byte-mult byte-char-after byte-char-syntax
 byte-buffer-substring byte-string= byte-string< byte-nthcdr byte-elt
 ;;;	varref flag
 ;;;	dup
 ;;;	varbind pop-up-windows
 ;;;	not
 ;;;
 ;;; we break the program, because it will appear that pop-up-windows and
 ;;; old-pop-ups are not EQ when really they are.  So we have to know what
 ;;; the BOOL variables are, and not perform this optimization on them.
 ;;;
 ;;; This used to hold a large list of boolean variables, which had to
 	      ;;
 	      ;; goto-X-if-nil     goto-Y X:  -->  goto-Y-if-non-nil X:
 	      ;; goto-X-if-non-nil goto-Y X:  -->  goto-Y-if-nil     X:
 	      ;;
 	      ;; it is wrong to do the same thing for the -else-pop variants.
 	      ;;
 	      ((and (or (eq 'byte-goto-if-nil (car lap0))
 			(eq 'byte-goto-if-not-nil (car lap0)))	; gotoX
 		    (eq 'byte-goto (car lap1))			; gotoY
 		    (eq (cdr lap0) lap2))			; TAG X
 	       (let ((inverse (if (eq 'byte-goto-if-nil (car lap0))
 			     (not (eq 'TAG (car (car tmp)))))
 		   (if opt-p (setq deleted (cons (car tmp) deleted)
 				   str (concat str " %s")
 				   i (1+ i))))
 		 (if opt-p
 		     (let ((tagstr
 			    (if (eq 'TAG (car (car tmp)))
 				(format "%d:" (car (cdr (car tmp))))
 			      (or (car tmp) ""))))
 		       (if (< i 6)
 			   (apply 'byte-compile-log-lap-1
 				     (byte-goto-if-nil-else-pop .
 				      byte-goto-if-not-nil-else-pop)
 				     (byte-goto-if-not-nil-else-pop .
 				      byte-goto-if-nil-else-pop))))
 			newtag)
 		  (nth 1 newtag)
 		  )
 		 (setcdr tmp (cons (setcdr lap0 newtag) (cdr tmp)))
 		 (if (eq (car (car tmp)) 'byte-goto-if-nil-else-pop)
 		     ;; We can handle this case but not the -if-not-nil case,

Mercurial > hg > xemacs-beta

comparison lisp/byte-optimize.el @ 398:74fd4e045ea6 r21-2-29