X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Fbyte-optimize.el;h=8ae9d2418659a4ec09ea3c1e8bd796688a6b3e61;hb=6f6c2759db74292539455548959e9668891f6962;hp=95e7cb4d2f7e1ec4e91b34abcf5f640fea235b10;hpb=a5f466de30a3e927ed1146b0c7e3870e71465c8f;p=chise%2Fxemacs-chise.git.1

diff --git a/lisp/byte-optimize.el b/lisp/byte-optimize.el
index 95e7cb4..8ae9d24 100644
--- a/lisp/byte-optimize.el
+++ b/lisp/byte-optimize.el
@@ -2,8 +2,9 @@
 
 ;;; Copyright (c) 1991, 1994 Free Software Foundation, Inc.
 
-;; Author: Jamie Zawinski <jwz@netscape.com>
-;;	Hallvard Furuseth <hbf@ulrik.uio.no>
+;; Authors: Jamie Zawinski <jwz@jwz.org>
+;;          Hallvard Furuseth <hbf@ulrik.uio.no>
+;;          Martin Buchholz <martin@xemacs.org>
 ;; Keywords: internal
 
 ;; This file is part of XEmacs.
@@ -19,11 +20,15 @@
 ;; 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 
+;; 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.
+;;; Synched up with: FSF 20.7 except where marked.
+;;; [[ Synched up with: FSF 20.7. ]]
+;;; DO NOT PUT IN AN INVALID SYNC MESSAGE WHEN YOU DO A PARTIAL SYNC. --ben
+
+;; BEGIN SYNC WITH 20.7.
 
 ;;; Commentary:
 
@@ -32,7 +37,7 @@
 ;; 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 
+;; 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.
 ;;
@@ -64,17 +69,17 @@
 ;; Simple defsubsts often produce forms like
 ;;    (let ((v1 (f1)) (v2 (f2)) ...)
 ;;       (FN v1 v2 ...))
-;; It would be nice if we could optimize this to 
+;; 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 
+;; 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 
+;; 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
@@ -109,7 +114,7 @@
 ;;
 ;; 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 
+;; 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))
@@ -131,8 +136,8 @@
 ;;
 ;; 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 
+;; 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
@@ -142,17 +147,17 @@
 ;; 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).  
+;; 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 
+;; 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 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:
@@ -166,7 +171,7 @@
 ;; error free also they may act as true-constants.
 
 ;;(disassemble #'(lambda (x) (and (point) (foo))))
-;; When 
+;; 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
@@ -177,13 +182,13 @@
 ;;(disassemble #'(lambda (x) (eq (if (point) 'a 'b) 'c)))
 ;;(disassemble #'(lambda (x) (if (point) (eq 'a 'c) (eq 'b 'c))))
 
-;; (car (cons A B)) -> (progn B A)
+;; (car (cons A B)) -> (prog1 A B)
 ;;(disassemble #'(lambda (x) (car (cons (foo) 42))))
 
 ;; (cdr (cons A B)) -> (progn A B)
 ;;(disassemble #'(lambda (x) (cdr (cons 42 (foo)))))
 
-;; (car (list A B ...)) -> (progn B ... A)
+;; (car (list A B ...)) -> (prog1 A ... B)
 ;;(disassemble #'(lambda (x) (car (list (foo) 42 (bar)))))
 
 ;; (cdr (list A B ...)) -> (progn A (list B ...))
@@ -291,11 +296,13 @@
 				(compiled-function-constants fn)
 				(compiled-function-stack-depth fn)))
 		    (cdr form)))
-	  (if (not (eq (car fn) 'lambda)) (error "%s is not a lambda" name))
-	  (cons fn (cdr form)))))))
+	  (if (eq (car-safe fn) 'lambda)
+	      (cons fn (cdr form))
+	    ;; Give up on inlining.
+	    form))))))
 
 ;;; ((lambda ...) ...)
-;;; 
+;;;
 (defun byte-compile-unfold-lambda (form &optional name)
   (or name (setq name "anonymous lambda"))
   (let ((lambda (car form))
@@ -350,7 +357,10 @@
 		(byte-compile-warn
 		 "attempt to open-code %s with too many arguments" name))
 	    form)
-	(let ((newform 
+       ;; This line, introduced in v1.10, can cause an infinite
+       ;; recursion when inlining recursive defsubst's
+;      (setq body (mapcar 'byte-optimize-form body))
+	(let ((newform
 	       (if bindings
 		   (cons 'let (cons (nreverse bindings) body))
 		 (cons 'progn body))))
@@ -435,28 +445,28 @@
 	     (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
@@ -472,15 +482,19 @@
 		 (if (and (cdr form) (null backwards))
 		     (byte-compile-log
 		      "  all subforms of %s called for effect; deleted" form))
-		 (and backwards
-		      (cons fn (nreverse backwards))))
+		 (when backwards
+		   ;; Now optimize the rest of the forms. We need the return
+		   ;; values. We already did the car.
+		   (setcdr backwards
+			   (mapcar 'byte-optimize-form (cdr backwards))))
+		 (cons fn (nreverse backwards)))
 	     (cons fn (mapcar 'byte-optimize-form (cdr form)))))
 
 	  ((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
@@ -496,7 +510,7 @@
 	   (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
@@ -514,7 +528,15 @@
 		    (setq form (macroexpand form
 					    byte-compile-macro-environment))))
 	   (byte-optimize-form form for-effect))
-	  
+
+	  ;; Support compiler macros as in cl.el.
+	  ((and (fboundp 'compiler-macroexpand)
+		(symbolp (car-safe form))
+		(get (car-safe form) 'cl-compiler-macro)
+	        (not (eq form
+		         (setq form (compiler-macroexpand form)))))
+	   (byte-optimize-form form for-effect))
+
 	  ((not (symbolp fn))
 	   (or (eq 'mocklisp (car-safe fn)) ; ha!
 	       (byte-compile-warn "%s is a malformed function"
@@ -532,7 +554,7 @@
 	   ;; 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
@@ -602,7 +624,7 @@
 	 ((keywordp ,form))))
 
 ;; If the function is being called with constant numeric args,
-;; evaluate as much as possible at compile-time.  This optimizer 
+;; 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)
@@ -695,126 +717,72 @@
 				(list (apply fun (nreverse constants)))))))))
     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))
-	 (condition-case ()
-	     (eval form)
-	   (error form)))
-
-	;; `add1' and `sub1' are a marginally fewer instructions
-	;; than `plus' and `minus', so use them when possible.
-	((and (null (nthcdr 3 form))
-	      (eq (nth 2 form) 1))
-	 (list '1+ (nth 1 form)))	; (+ x 1)  -->  (1+ x)
-	((and (null (nthcdr 3 form))
-	      (eq (nth 1 form) 1))
-	 (list '1+ (nth 2 form)))	; (+ 1 x)  -->  (1+ x)
-	((and (null (nthcdr 3 form))
-	      (eq (nth 2 form) -1))
-	 (list '1- (nth 1 form)))	; (+ x -1)  -->  (1- x)
-	((and (null (nthcdr 3 form))
-	      (eq (nth 1 form) -1))
-	 (list '1- (nth 2 form)))	; (+ -1 x)  -->  (1- x)
-
-;;; It is not safe to delete the function entirely
-;;; (actually, it would be safe if we know the sole arg
-;;; is not a marker).
-;;	((null (cdr (cdr form))) (nth 1 form))
-	(t form)))
+;; END SYNC WITH 20.7.
 
-(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.
-  (let ((last (car (reverse (nthcdr 3 form)))))
-    (cond ((eq 0 last)
-	   ;; (- x y ... 0)  --> (- x y ...)
-	   (setq form (copy-sequence form))
-	   (setcdr (cdr (cdr form)) (delq 0 (nthcdr 3 form))))
-	  ;; If form is (- CONST foo... CONST), merge first and last.
-	  ((and (numberp (nth 1 form))
-		(numberp last))
-	   (setq form (nconc (list '- (- (nth 1 form) last) (nth 2 form))
-			     (delq last (copy-sequence (nthcdr 3 form))))))))
-  (setq form
-;;; It is not safe to delete the function entirely
-;;; (actually, it would be safe if we know the sole arg
-;;; is not a marker).
-;;;  (if (eq (nth 2 form) 0)
-;;;      (nth 1 form)			; (- x 0)  -->  x
-    (byte-optimize-predicate
-     (if (and (null (cdr (cdr (cdr form))))
-	      (eq (nth 1 form) 0))	; (- 0 x)  -->  (- x)
-	 (cons (car form) (cdr (cdr form)))
-       form))
-;;;    )
-    )
-
-  ;; `add1' and `sub1' are a marginally fewer instructions than `plus'
-  ;; and `minus', so use them when possible.
-  (cond ((and (null (nthcdr 3 form))
-	      (eq (nth 2 form) 1))
-	 (list '1- (nth 1 form)))	; (- x 1)  -->  (1- x)
-	((and (null (nthcdr 3 form))
-	      (eq (nth 2 form) -1))
-	 (list '1+ (nth 1 form)))	; (- x -1)  -->  (1+ x)
-	(t
-	 form))
-  )
+;;; It is not safe to optimize calls to arithmetic ops with one arg
+;;; away entirely (actually, it would be safe if we know the sole arg
+;;; is not a marker or if it appears in other arithmetic).
+
+;;; But this degree of paranoia is normally unjustified, so optimize unless
+;;; the user has done (declaim (optimize (safety 3))).  See bytecomp.el.
+
+(defun byte-optimize-plus (form)
+  (byte-optimize-predicate (byte-optimize-delay-constants-math form 1 '+)))
 
 (defun byte-optimize-multiply (form)
   (setq form (byte-optimize-delay-constants-math form 1 '*))
-  ;; If there is a constant in FORM, it is now the last element.
-  (cond ((null (cdr form)) 1)
-;;; It is not safe to delete the function entirely
-;;; (actually, it would be safe if we know the sole arg
-;;; is not a marker or if it appears in other arithmetic).
-;;;	((null (cdr (cdr form))) (nth 1 form))
-	((let ((last (car (reverse form))))
-	   (cond ((eq 0 last)  (cons 'progn (cdr form)))
-		 ((eq 1 last)  (delq 1 (copy-sequence form)))
-		 ((eq -1 last) (list '- (delq -1 (copy-sequence form))))
-		 ((and (eq 2 last)
-		       (memq t (mapcar 'symbolp (cdr form))))
-		  (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))))
+  ;; If there is a constant integer in FORM, it is now the last element.
+
+  (case (car (last form))
+    ;; (* x y 0) --> (progn x y 0)
+    (0 (cons 'progn (cdr form)))
+    (t (byte-optimize-predicate form))))
+
+(defun byte-optimize-minus (form)
+  ;; Put constants at the end, except the first arg.
+  (setq form (byte-optimize-delay-constants-math form 2 '+))
+  ;; Now only the first and last args can be integers.
+  (let ((last (car (last (nthcdr 3 form)))))
+    (cond
+     ;; If form is (- CONST foo... CONST), merge first and last.
+     ((and (numberp (nth 1 form)) (numberp last))
+      (decf (nth 1 form) last)
+      (butlast form))
+
+     ;; (- 0 ...) -->
+     ((eq 0 (nth 1 form))
+      (case (length form)
+	;; (- 0) --> 0
+	(2 0)
+	;; (- 0 x)  -->  (- x)
+	(3 `(- ,(nth 2 form)))
+	;; (- 0 x y ...)  -->  (- (- x) y ...)
+	(t `(- (- ,(nth 2 form)) ,@(nthcdr 3 form)))))
+
+     (t (byte-optimize-predicate form)))))
 
 (defun byte-optimize-divide (form)
+  ;; Put constants at the end, except the first arg.
   (setq form (byte-optimize-delay-constants-math form 2 '*))
-  (let ((last (car (reverse (cdr (cdr form))))))
-    (if (numberp last)
-	(cond ((= (length form) 3)
-	       (if (and (numberp (nth 1 form))
-			(not (zerop last))
-			(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)))
-	      ((numberp (nth 1 form))
-	       (setq form (cons (car form)
-				(cons (/ (nth 1 form) last)
-				      (byte-compile-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)
-		      (nth 1 form))))
-	  (form))))
+  ;; Now only the first and last args can be integers.
+  (let ((last (car (last (nthcdr 3 form)))))
+    (cond
+     ;; If form is (/ CONST foo... CONST), merge first and last.
+     ((and (numberp (nth 1 form)) (numberp last))
+      (condition-case nil
+	  (cons (nth 0 form)
+		(cons (/ (nth 1 form) last)
+		      (butlast (cdr (cdr form)))))
+	(error form)))
+
+     ;; (/ 0 x y) --> (progn x y 0)
+     ((eq (nth 1 form) 0)
+      (append '(progn) (cdr (cdr form)) '(0)))
+
+     ;; We don't have to check for divide-by-zero because `/' does.
+     (t (byte-optimize-predicate form)))))
+
+;; BEGIN SYNC WITH 20.7.
 
 (defun byte-optimize-logmumble (form)
   (setq form (byte-optimize-delay-constants-math form 1 (car form)))
@@ -846,9 +814,11 @@
       (setq ok (byte-compile-constp (car rest))
 	    rest (cdr rest)))
     (if ok
-	(condition-case ()
+	(condition-case err
 	    (list 'quote (eval form))
-	  (error form))
+	  (error
+	   (byte-compile-warn "evaluating %s: %s" form err)
+	   form))
 	form)))
 
 (defun byte-optimize-identity (form)
@@ -859,22 +829,61 @@
 		       (if (= 1 (length (cdr form))) "" "s"))
     form))
 
+(defun byte-optimize-car (form)
+  (let ((arg (cadr form)))
+    (cond
+     ((and (byte-compile-trueconstp arg)
+	   (not (and (consp arg)
+		     (eq (car arg) 'quote)
+		     (listp (cadr arg)))))
+      (byte-compile-warn
+       "taking car of a constant: %s" arg)
+      form)
+     ((and (eq (car-safe arg) 'cons)
+	   (eq (length arg) 3))
+      `(prog1 ,(nth 1 arg) ,(nth 2 arg)))
+     ((eq (car-safe arg) 'list)
+      `(prog1 ,@(cdr arg)))
+     (t
+      (byte-optimize-predicate form)))))
+
+(defun byte-optimize-cdr (form)
+  (let ((arg (cadr form)))
+    (cond
+     ((and (byte-compile-trueconstp arg)
+	   (not (and (consp arg)
+		     (eq (car arg) 'quote)
+		     (listp (cadr arg)))))
+      (byte-compile-warn
+       "taking cdr of a constant: %s" arg)
+      form)
+     ((and (eq (car-safe arg) 'cons)
+	    (eq (length arg) 3))
+       `(progn ,(nth 1 arg) ,(nth 2 arg)))
+      ((eq (car-safe arg) 'list)
+       (if (> (length arg) 2)
+	   `(progn ,(cadr arg) (list ,@(cddr arg)))
+	 (cadr arg)))
+      (t
+       (byte-optimize-predicate form)))))
+
 (put 'identity 'byte-optimizer 'byte-optimize-identity)
 
 (put '+   'byte-optimizer 'byte-optimize-plus)
 (put '*   'byte-optimizer 'byte-optimize-multiply)
 (put '-   'byte-optimizer 'byte-optimize-minus)
 (put '/   'byte-optimizer 'byte-optimize-divide)
+(put '%   'byte-optimizer 'byte-optimize-predicate)
 (put 'max 'byte-optimizer 'byte-optimize-associative-math)
 (put 'min 'byte-optimizer 'byte-optimize-associative-math)
 
-(put '=   'byte-optimizer 'byte-optimize-binary-predicate)
 (put 'eq  'byte-optimizer 'byte-optimize-binary-predicate)
 (put 'eql 'byte-optimizer 'byte-optimize-binary-predicate)
 (put 'equal   'byte-optimizer 'byte-optimize-binary-predicate)
 (put 'string= 'byte-optimizer 'byte-optimize-binary-predicate)
 (put 'string-equal 'byte-optimizer 'byte-optimize-binary-predicate)
 
+(put '=   'byte-optimizer 'byte-optimize-predicate)
 (put '<   'byte-optimizer 'byte-optimize-predicate)
 (put '>   'byte-optimizer 'byte-optimize-predicate)
 (put '<=  'byte-optimizer 'byte-optimize-predicate)
@@ -890,19 +899,20 @@
 (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 'car 'byte-optimizer 'byte-optimize-predicate)
-(put 'cdr 'byte-optimizer 'byte-optimize-predicate)
+(put 'car 'byte-optimizer 'byte-optimize-car)
+(put 'cdr 'byte-optimizer 'byte-optimize-cdr)
 (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 
+;; 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
@@ -957,41 +967,27 @@
 	(byte-optimize-predicate form)
       (nth 1 form))))
 
+;; END SYNC WITH 20.7.
+
+;;; For the byte optimizer, `cond' is just overly sweet syntactic sugar.
+;;; So we rewrite (cond ...) in terms of `if' and `or',
+;;; which are easier to optimize.
 (defun byte-optimize-cond (form)
-  ;; if any clauses have a literal nil as their test, throw them away.
-  ;; if any clause has a literal non-nil constant as its test, throw
-  ;; away all following clauses.
-  (let (rest)
-    ;; This must be first, to reduce (cond (t ...) (nil)) to (progn t ...)
-    (while (setq rest (assq nil (cdr form)))
-      (setq form (delq rest (copy-sequence form))))
-    (if (memq nil (cdr form))
-	(setq form (delq nil (copy-sequence form))))
-    (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)))))
-		   ((cdr rest)
-		    (setq form (copy-sequence form))
-		    (setcdr (memq (car rest) form) nil)))
-	     (setq rest nil)))))
-  ;;
-  ;; Turn (cond (( <x> )) ... ) into (or <x> (cond ... ))
-  (if (eq 'cond (car-safe form))
-      (let ((clauses (cdr form)))
-	(if (and (consp (car clauses))
-		 (null (cdr (car clauses))))
-	    (list 'or (car (car clauses))
-		  (byte-optimize-cond
-		   (cons (car form) (cdr (cdr form)))))
-	  form))
-    form))
+  (byte-optimize-cond-1 (cdr form)))
+
+(defun byte-optimize-cond-1 (clauses)
+  (cond
+   ((null clauses) nil)
+   ((consp (car clauses))
+    (nconc
+     (case (length (car clauses))
+       (1 `(or ,(nth 0 (car clauses))))
+       (2 `(if ,(nth 0 (car clauses)) ,(nth 1 (car clauses))))
+       (t `(if ,(nth 0 (car clauses)) (progn ,@(cdr (car clauses))))))
+     (when (cdr clauses) (list (byte-optimize-cond-1 (cdr clauses))))))
+   (t (error "malformed cond clause %s" (car clauses)))))
+
+;; BEGIN SYNC WITH 20.7.
 
 (defun byte-optimize-if (form)
   ;; (if <true-constant> <then> <else...>) ==> <then>
@@ -1033,12 +1029,72 @@
 (put 'if    'byte-optimizer 'byte-optimize-if)
 (put 'while 'byte-optimizer 'byte-optimize-while)
 
+;; The supply of bytecodes is small and constrained by backward compatibility.
+;; Several functions have byte-coded versions and hence are very efficient.
+;; Related functions which can be expressed in terms of the byte-coded
+;; ones should be transformed into bytecoded calls for efficiency.
+;; This is especially the case for functions with a backward- and
+;; forward- version, but with a bytecode only for the forward one.
+
+;; Some programmers have hand-optimized calls like (backward-char)
+;; into the call (forward-char -1).
+;; But it's so much nicer for the byte-compiler to do this automatically!
+
+;; (char-before) ==> (char-after (1- (point)))
+(put 'char-before   'byte-optimizer 'byte-optimize-char-before)
+(defun byte-optimize-char-before (form)
+  `(char-after
+    ,(cond
+      ((null (nth 1 form))
+       '(1- (point)))
+      ((equal '(point) (nth 1 form))
+       '(1- (point)))
+      (t `(1- (or ,(nth 1 form) (point)))))
+    ,@(cdr (cdr form))))
+
+;; (backward-char n) ==> (forward-char (- n))
+(put 'backward-char 'byte-optimizer 'byte-optimize-backward-char)
+(defun byte-optimize-backward-char (form)
+  `(forward-char
+    ,(typecase (nth 1 form)
+       (null -1)
+       (integer (- (nth 1 form)))
+       (t `(- (or ,(nth 1 form) 1))))
+    ,@(cdr (cdr form))))
+
+;; (backward-word n) ==> (forward-word (- n))
+(put 'backward-word 'byte-optimizer 'byte-optimize-backward-word)
+(defun byte-optimize-backward-word (form)
+  `(forward-word
+    ,(typecase (nth 1 form)
+       (null -1)
+       (integer (- (nth 1 form)))
+       (t `(- (or ,(nth 1 form) 1))))
+    ,@(cdr (cdr form))))
+
+;; The following would be a valid optimization of the above kind, but
+;; the gain in performance is very small, since the saved funcall is
+;; counterbalanced by the necessity of adding a bytecode for (point).
+;;
+;; Also, users are more likely to have modified the behavior of
+;; delete-char via advice or some similar mechanism.  This is much
+;; less of a problem for the previous functions because it wouldn't
+;; make sense to modify the behaviour of `backward-char' without also
+;; modifying `forward-char', for example.
+
+;; (delete-char n) ==> (delete-region (point) (+ (point) n))
+;; (put 'delete-char 'byte-optimizer 'byte-optimize-delete-char)
+;; (defun byte-optimize-delete-char (form)
+;;   (case (length (cdr form))
+;;     (0 `(delete-region (point) (1+ (point))))
+;;     (1 `(delete-region (point) (+ (point) ,(nth 1 form))))
+;;     (t form)))
+
 ;; 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)
 
-
 (defun byte-optimize-funcall (form)
   ;; (funcall '(lambda ...) ...) ==> ((lambda ...) ...)
   ;; (funcall 'foo ...) ==> (foo ...)
@@ -1102,8 +1158,20 @@
       (while (>= (setq count (1- count)) 0)
 	(setq form (list 'cdr form)))
       form)))
+
+(put 'concat 'byte-optimizer 'byte-optimize-concat)
+(defun byte-optimize-concat (form)
+  (let ((args (cdr form))
+	(constant t))
+    (while (and args constant)
+      (or (byte-compile-constp (car args))
+	  (setq constant nil))
+      (setq args (cdr args)))
+    (if constant
+	(eval form)
+      form)))
 
-;;; enumerating those functions which need not be called if the returned 
+;;; 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))
@@ -1141,7 +1209,7 @@
 	 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
@@ -1155,7 +1223,7 @@
 	 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
@@ -1172,8 +1240,7 @@
 	 hash-table-p
 	 identity ignore integerp integer-or-marker-p interactive-p
 	 invocation-directory invocation-name
-	 ;; keymapp may autoload in XEmacs, so not on this list!
-	 list listp
+	 keymapp list listp
 	 make-marker mark mark-marker markerp memory-limit minibuffer-window
 	 ;; mouse-movement-p not in XEmacs
 	 natnump nlistp not null number-or-marker-p numberp
@@ -1197,7 +1264,7 @@
 
 (defun byte-compile-splice-in-already-compiled-code (form)
   ;; form is (byte-code "..." [...] n)
-  (if (not (memq byte-optimize '(t lap)))
+  (if (not (memq byte-optimize '(t byte)))
       (byte-compile-normal-call form)
     (byte-inline-lapcode
      (byte-decompile-bytecode-1 (nth 1 form) (nth 2 form) t))
@@ -1219,9 +1286,7 @@
   ;; fetch and return the offset for the current opcode.
   ;; return NIL if this opcode has no offset
   ;; OP, PTR and BYTES are used and set dynamically
-  (defvar op)
-  (defvar ptr)
-  (defvar bytes)
+  (declare (special op ptr bytes))
   (cond ((< op byte-nth)
 	 (let ((tem (logand op 7)))
 	   (setq op (logand op 248))
@@ -1316,7 +1381,9 @@
 					     tags)))))))
 	    ((cond ((eq op 'byte-constant2) (setq op 'byte-constant) t)
 		   ((memq op byte-constref-ops)))
-	     (setq tmp (aref constvec offset)
+	     (setq tmp (if (>= offset (length constvec))
+			   (list 'out-of-range offset)
+			 (aref constvec offset))
 		   offset (if (eq op 'byte-constant)
 			      (byte-compile-get-constant tmp)
 			    (or (assq tmp byte-compile-variables)
@@ -1365,11 +1432,14 @@
 (defconst byte-after-unbind-ops
    '(byte-constant byte-dup
      byte-symbolp byte-consp byte-stringp byte-listp byte-numberp byte-integerp
-     byte-eq byte-equal byte-not
+     byte-eq byte-not
      byte-cons byte-list1 byte-list2	; byte-list3 byte-list4
      byte-interactive-p)
    ;; How about other side-effect-free-ops?  Is it safe to move an
    ;; error invocation (such as from nth) out of an unwind-protect?
+   ;; No, it is not, because the unwind-protect forms can alter
+   ;; the inside of the object to which nth would apply.
+   ;; For the same reason, byte-equal was deleted from this list.
    "Byte-codes that can be moved past an unbind.")
 
 (defconst byte-compile-side-effect-and-error-free-ops
@@ -1381,7 +1451,7 @@
     byte-current-buffer byte-interactive-p))
 
 (defconst byte-compile-side-effect-free-ops
-  (nconc 
+  (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
@@ -1413,7 +1483,7 @@
 ;;;	varbind pop-up-windows
 ;;;	not
 ;;;
-;;; we break the program, because it will appear that pop-up-windows and 
+;;; 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.
 ;;;
@@ -1425,39 +1495,14 @@
 ;;; variables.
 
 ;(defconst byte-boolean-vars
-;  '(abbrev-all-caps purify-flag find-file-compare-truenames
-;    find-file-use-truenames delete-auto-save-files byte-metering-on
-;    x-seppuku-on-epipe zmacs-regions zmacs-region-active-p
-;    zmacs-region-stays atomic-extent-goto-char-p
-;    suppress-early-error-handler-backtrace noninteractive
-;    inhibit-early-packages inhibit-autoloads debug-paths
-;    inhibit-site-lisp debug-on-quit debug-on-next-call
-;    modifier-keys-are-sticky x-allow-sendevents
-;    mswindows-dynamic-frame-resize focus-follows-mouse
-;    inhibit-input-event-recording enable-multibyte-characters
-;    disable-auto-save-when-buffer-shrinks
-;    allow-deletion-of-last-visible-frame indent-tabs-mode
-;    load-in-progress load-warn-when-source-newer
-;    load-warn-when-source-only load-ignore-elc-files
-;    load-force-doc-strings fail-on-bucky-bit-character-escapes
-;    popup-menu-titles menubar-show-keybindings completion-ignore-case
-;    canna-empty-info canna-through-info canna-underline
-;    canna-inhibit-hankakukana enable-multibyte-characters
-;    re-short-flag x-handle-non-fully-specified-fonts
-;    print-escape-newlines print-readably delete-exited-processes
-;    windowed-process-io visible-bell no-redraw-on-reenter
-;    cursor-in-echo-area inhibit-warning-display
-;    column-number-start-at-one parse-sexp-ignore-comments
-;    words-include-escapes scroll-on-clipped-lines)
-;  "DEFVAR_BOOL variables.  Giving these any non-nil value sets them to t.
-;If this does not enumerate all DEFVAR_BOOL variables, the byte-optimizer
-;may generate incorrect code.")
+;   ...)
 
 (defun byte-optimize-lapcode (lap &optional for-effect)
   "Simple peephole optimizer.  LAP is both modified and returned."
-  (let (lap0 ;; off0 unused
-	lap1 ;; off1
-	lap2 ;; off2
+  (let (lap0
+	lap1
+	lap2
+	variable-frequency
 	(keep-going 'first-time)
 	(add-depth 0)
 	rest tmp tmp2 tmp3
@@ -1593,7 +1638,7 @@
 	      ;; 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
@@ -1696,7 +1741,7 @@
 				   str (concat str " %s")
 				   i (1+ i))))
 		 (if opt-p
-		     (let ((tagstr 
+		     (let ((tagstr
 			    (if (eq 'TAG (car (car tmp)))
 				(format "%d:" (car (cdr (car tmp))))
 			      (or (car tmp) ""))))
@@ -1878,7 +1923,7 @@
 				     (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)))
@@ -1903,28 +1948,31 @@
     ;; Rebuild byte-compile-constants / byte-compile-variables.
     ;; Simple optimizations that would inhibit other optimizations if they
     ;; were done in the optimizing loop, and optimizations which there is no
-    ;;  need to do more than once.
+    ;; need to do more than once.
     (setq byte-compile-constants nil
-	  byte-compile-variables nil)
+	  byte-compile-variables nil
+	  variable-frequency (make-hash-table :test 'eq))
     (setq rest lap)
     (while rest
       (setq lap0 (car rest)
 	    lap1 (nth 1 rest))
       (if (memq (car lap0) byte-constref-ops)
-	  (if (eq (cdr lap0) 'byte-constant)
-	      (or (memq (cdr lap0) byte-compile-variables)
-		  (setq byte-compile-variables (cons (cdr lap0)
-						     byte-compile-variables)))
+	  (if (not (eq (car lap0) 'byte-constant))
+	      (progn 
+		(incf (gethash (cdr lap0) variable-frequency 0))
+		(or (memq (cdr lap0) byte-compile-variables)
+		    (setq byte-compile-variables
+			  (cons (cdr lap0) byte-compile-variables))))
 	    (or (memq (cdr lap0) byte-compile-constants)
 		(setq byte-compile-constants (cons (cdr lap0)
 						   byte-compile-constants)))))
       (cond (;;
-	     ;; const-C varset-X const-C  -->  const-C dup varset-X
+	     ;; const-C varset-X  const-C  -->  const-C dup varset-X
 	     ;; const-C varbind-X const-C  -->  const-C dup varbind-X
 	     ;;
 	     (and (eq (car lap0) 'byte-constant)
 		  (eq (car (nth 2 rest)) 'byte-constant)
-		  (eq (cdr lap0) (car (nth 2 rest)))
+		  (eq (cdr lap0) (cdr (nth 2 rest)))
 		  (memq (car lap1) '(byte-varbind byte-varset)))
 	     (byte-compile-log-lap "  %s %s %s\t-->\t%s dup %s"
 				   lap0 lap1 lap0 lap0 lap1)
@@ -1960,6 +2008,21 @@
 	     (setcdr lap1 (+ (cdr lap1) (cdr lap0))))
 	    )
       (setq rest (cdr rest)))
+    ;; Since the first 6 entries of the compiled-function constants
+    ;; vector are most efficient for varref/set/bind ops, we sort by
+    ;; reference count.  This generates maximally space efficient and
+    ;; pretty time-efficient byte-code.  See `byte-compile-constants-vector'.
+    (setq byte-compile-variables
+	  (sort byte-compile-variables
+		#'(lambda (v1 v2)
+		    (< (gethash v1 variable-frequency)
+		       (gethash v2 variable-frequency)))))
+    ;; Another hack - put the most used variable in position 6, for
+    ;; better locality of reference with adjoining constants.
+    (let ((tail (last byte-compile-variables 6)))
+      (setq byte-compile-variables
+	    (append (nbutlast byte-compile-variables 6)
+		    (nreverse tail))))
     (setq byte-compile-maxdepth (+ byte-compile-maxdepth add-depth)))
   lap)
 
@@ -1988,4 +2051,6 @@
 	  byte-optimize-lapcode))))
  nil)
 
+;; END SYNC WITH 20.7.
+
 ;;; byte-optimize.el ends here