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)