[movitz-cvs] CVS update: movitz/compiler.lisp

[Frode Vatvedt Fjeld]

Update of /project/movitz/cvsroot/movitz
In directory common-lisp.net:/tmp/cvs-serv8128

Modified Files:
	compiler.lisp 
Log Message:
Worked on the peephole optimizer a bit.

Date: Tue Apr 20 19:04:12 2004
Author: ffjeld

Index: movitz/compiler.lisp
diff -u movitz/compiler.lisp:1.56 movitz/compiler.lisp:1.57
--- movitz/compiler.lisp:1.56	Mon Apr 19 16:34:55 2004
+++ movitz/compiler.lisp	Tue Apr 20 19:04:12 2004
@@ -8,7 +8,7 @@
 ;;;; Created at:    Wed Oct 25 12:30:49 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: compiler.lisp,v 1.56 2004/04/19 20:34:55 ffjeld Exp $
+;;;; $Id: compiler.lisp,v 1.57 2004/04/20 23:04:12 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -1417,7 +1417,6 @@
 	     (and (or (not dest)
 		      (equal dest (second (twop-p c op))))
 		  (first (twop-p c op)))))
-	 #+ignore
 	 (isrc (c)
 	   (let ((c (ignore-instruction-prefixes c)))
 	     (ecase (length (cdr c))
@@ -1486,6 +1485,25 @@
 		      (and (member register '(:edx))
 			   (member (global-funcall-p i)
 				   '(fast-car fast-cdr fast-car-ebx fast-cdr-ebx)))))))
+	 (operand-register-indirect-p (operand register)
+	   (and (consp operand)
+		(tree-search operand register)))
+	 (doesnt-read-register-p (i register)
+	   (let ((i (ignore-instruction-prefixes i)))
+	     (or (symbolp i)
+		 (and (simple-instruction-p i)
+		      (if (member (instruction-is i) '(:movl))
+			  (and (not (eq register (twop-src i)))
+			       (not (operand-register-indirect-p (twop-src i) register))
+			       (not (operand-register-indirect-p (twop-dst i) register)))
+			(not (or (eq register (isrc i))
+				 (operand-register-indirect-p (isrc i) register)
+				 (eq register (idst i))
+				 (operand-register-indirect-p (idst i) register)))))
+		 (instruction-is i :frame-map)
+		 (and (member register '(:edx))
+		      (member (global-funcall-p i)
+			      '(fast-car fast-cdr fast-car-ebx fast-cdr-ebx))))))
 	 (register-operand (op)
 	   (and (member op '(:eax :ebx :ecx :edx :edi))
 		op))
@@ -1901,6 +1919,43 @@
 				   (append (list i3 i i2)
 					   `((:movl ,reg ,(twop-dst i3)))))
 			       next-pc (cdddr pc))))
+		      ;; ((:movl <foo> <bar>) label (:movl <zot> <bar>))
+		      ;; => (label (:movl <zot> <bar>))
+		      ((and (instruction-is i :movl)
+			    (or (symbolp i2)
+				(and (not (branch-instruction-label i2))
+				     (symbolp (twop-dst i))
+				     (doesnt-read-register-p i2 (twop-dst i))))
+			    (instruction-is i3 :frame-map)
+			    (instruction-is i4 :movl)
+			    (equal (twop-dst i) (twop-dst i4))
+			    (not (and (symbolp (twop-dst i))
+				      (operand-register-indirect-p (twop-src i4)
+								   (twop-dst i)))))
+		       (setq p (list i2 i3 i4)
+			     next-pc (nthcdr 4 pc))
+		       (explain nil "Removed redundant store before ~A: ~A"
+				i2 (subseq pc 0 4)))
+		      ((and (instruction-is i :movl)
+			    (not (branch-instruction-label i2))
+			    (symbolp (twop-dst i))
+			    (doesnt-read-register-p i2 (twop-dst i))
+			    (instruction-is i3 :movl)
+			    (equal (twop-dst i) (twop-dst i3))
+			    (not (and (symbolp (twop-dst i))
+				      (operand-register-indirect-p (twop-src i3)
+								   (twop-dst i)))))
+		       (setq p (list i2 i3)
+			     next-pc (nthcdr 3 pc))
+		       (explain nil "Removed redundant store before ~A: ~A"
+				i2 (subseq pc 0 3)))
+		      ((and (member (instruction-is i)
+				    '(:cmpl :cmpb :cmpw :testl :testb :testw))
+			    (member (instruction-is i2)
+				    '(:cmpl :cmpb :cmpw :testl :testb :testw)))
+		       (setq p (list i2)
+			     next-pc (nthcdr 2 pc))
+		       (explain nil "Trimmed double test: ~A" (subseq pc 0 4)))
 		      ;; ((:jmp x) ...(no labels).... x ..)
 		      ;; => (x ...)
 		      ((let ((x (branch-instruction-label i t nil)))
@@ -1940,7 +1995,9 @@
 			    (null (find-branches-to-label unoptimized-code i))
 			    (not (member i keep-labels)))
 		       (setq p nil
-			     next-pc (cdr pc))
+			     next-pc (if (instruction-is i2 :frame-map)
+					 (cddr pc)
+				       (cdr pc)))
 		       (explain nil "unused label: ~S" i))
 		      ;; ((:jcc 'label) (:jmp 'y) label) => ((:jncc 'y) label)
 		      ((and (branch-instruction-label i)