Small LAP peephole optimization

[Dmitry Antipov <dmantipov@yandex.ru>]

[-- Attachment #1: Type: text/plain, Size: 733 bytes --]

Hello again,

this is a minor LAP peephole optimization intended to remove redundant
'(byte-constant 0) (byte-plus . 0)' byte code insns. As an obvious
example, for

(disassemble (byte-compile '(lambda (x y) (+ x (* 2 y)))))

it will produce

0       varref    x
1       varref    y
2       dup
3       plus
4       plus
5       return

instead of current

0       varref    x
1       varref    y
2       dup
3       plus
4       constant  0
5       plus
6       plus
7       return

During full bootstrap, this small optimization is performed for more
than 100 LAPs, thus removing ~400 byte code insns. It was also tested by
byte-force-recompile of all lisp, and hopefully it works.

There are also a few cosmetic cleanups.

Dmitry

[-- Attachment #2: byte_opt_const_0_plus.patch --]
[-- Type: text/plain, Size: 2785 bytes --]

Index: lisp/emacs-lisp/byte-opt.el
===================================================================
RCS file: /sources/emacs/emacs/lisp/emacs-lisp/byte-opt.el,v
retrieving revision 1.94
diff -u -r1.94 byte-opt.el
--- lisp/emacs-lisp/byte-opt.el	11 Apr 2007 17:10:42 -0000	1.94
+++ lisp/emacs-lisp/byte-opt.el	9 May 2007 06:43:58 -0000
@@ -1526,6 +1526,21 @@
 		      (setcdr lap0 0))
 		     ((error "Optimizer error: too much on the stack"))))
 	      ;;
+	      ;; constant 0 plus --> <deleted>
+	      ;;
+	      ((and (eq (car lap0) 'byte-constant)
+		    (numberp (cadr lap0))
+		    (zerop (cadr lap0))
+		    (eq (car lap1) 'byte-plus))
+	       (let ((tmp lap) (head nil))
+		 (while (not (eq lap0 (car tmp)))
+		   (setq head (append head (list (car tmp)))
+			 tmp (cdr tmp)))
+		 (byte-compile-log-lap "  %s %s\t-->\t<deleted>" lap0 lap1)
+		 (setq rest (cddr rest)
+		       lap (nconc head rest)
+		       keep-going t)))
+	      ;;
 	      ;; goto*-X X:  -->  X:
 	      ;;
 	      ((and (memq (car lap0) byte-goto-ops)
@@ -1537,10 +1552,9 @@
 		      (setcar lap0 (setq tmp 'byte-discard))
 		      (setcdr lap0 0))
 		     ((error "Depth conflict at tag %d" (nth 2 lap0))))
-	       (and (memq byte-optimize-log '(t byte))
-		    (byte-compile-log "  (goto %s) %s:\t-->\t%s %s:"
-				      (nth 1 lap1) (nth 1 lap1)
-				      tmp (nth 1 lap1)))
+	       (byte-compile-log-lap "  (goto %s) %s:\t-->\t%s %s:"
+				     (nth 1 lap1) (nth 1 lap1)
+				     tmp (nth 1 lap1))
 	       (setq keep-going t))
 	      ;;
 	      ;; varset-X varref-X  -->  dup varset-X
@@ -1672,8 +1686,8 @@
 		     (while (not (eq tmp tmp2))
 		       (setq tmp2 (cdr tmp2)
 			     str (concat str " dup")))
-		     (byte-compile-log-lap "  %s%s %s\t-->\t%s%s dup"
-					   lap0 str lap0 lap0 str)))
+		     (byte-compile-log-lap-1 "  %s%s %s\t-->\t%s%s dup"
+					     lap0 str lap0 lap0 str)))
 	       (setq keep-going t)
 	       (setcar (car tmp) 'byte-dup)
 	       (setcdr (car tmp) 0)
@@ -1684,9 +1698,8 @@
 	      ;;
 	      ((and (eq (car lap0) 'TAG)
 		    (eq (car lap1) 'TAG))
-	       (and (memq byte-optimize-log '(t byte))
-		    (byte-compile-log "  adjacent tags %d and %d merged"
-				      (nth 1 lap1) (nth 1 lap0)))
+	       (byte-compile-log-lap "  adjacent tags %d and %d merged"
+				     (nth 1 lap1) (nth 1 lap0))
 	       (setq tmp3 lap)
 	       (while (setq tmp2 (rassq lap0 tmp3))
 		 (setcdr tmp2 lap1)
@@ -1698,8 +1711,7 @@
 	      ;;
 	      ((and (eq 'TAG (car lap0))
 		    (not (rassq lap0 lap)))
-	       (and (memq byte-optimize-log '(t byte))
-		    (byte-compile-log "  unused tag %d removed" (nth 1 lap0)))
+	       (byte-compile-log-lap "  unused tag %d removed" (nth 1 lap0))
 	       (setq lap (delq lap0 lap)
 		     keep-going t))
 	      ;;

[-- Attachment #3: Type: text/plain, Size: 142 bytes --]

_______________________________________________
Emacs-devel mailing list
Emacs-devel@gnu.org
http://lists.gnu.org/mailman/listinfo/emacs-devel