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

[Frode Vatvedt Fjeld]

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

Modified Files:
	compiler.lisp 
Log Message:
Minor changes, mostly to do with knowing about the effect of the :cld
and :stc instructions.

Date: Wed Apr 14 10:38:14 2004
Author: ffjeld

Index: movitz/compiler.lisp
diff -u movitz/compiler.lisp:1.44 movitz/compiler.lisp:1.45
--- movitz/compiler.lisp:1.44	Tue Apr 13 09:03:10 2004
+++ movitz/compiler.lisp	Wed Apr 14 10:38:14 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.44 2004/04/13 13:03:10 ffjeld Exp $
+;;;; $Id: compiler.lisp,v 1.45 2004/04/14 14:38:14 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -1424,7 +1424,7 @@
 	 (non-destructuve-p (c)
 	   (let ((c (ignore-instruction-prefixes c)))
 	     (and (consp c)
-		  (member (car c) '(:testl :testb :pushl :cmpl :cmpb :frame-map)))))
+		  (member (car c) '(:testl :testb :pushl :cmpl :cmpb :frame-map :std)))))
 	 (simple-instruction-p (c)
 	   (let ((c (ignore-instruction-prefixes c)))
 	     (and (listp c)
@@ -1469,14 +1469,14 @@
 	 (preserves-register-p (i register)
 	   (let ((i (ignore-instruction-prefixes i)))
 	     (and (not (atom i))
-		  (or (and (member register '(:edx))
-			   (member (global-funcall-p i)
-				   '(fast-car fast-cdr fast-car-ebx fast-cdr-ebx)))
+		  (or (and (simple-instruction-p i)
+			   (not (eq register (idst i))))
 		      (instruction-is i :frame-map)
 		      (branch-instruction-label i)
 		      (non-destructuve-p i)
-		      (and (simple-instruction-p i)
-			   (not (eq register (idst i))))))))
+		      (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))
@@ -1915,6 +1915,11 @@
 			   (setq p (list `(,(car i) ',to)))
 			   (explain nil "branch redirect from ~S to ~S" from to)
 			   t)))
+		      ;; remove back-to-back std/cld
+		      ((and (instruction-is i :cld)
+			    (instruction-is i2 :std))
+		       (explain nil "removing back-to-back cld, std.")
+		       (setq p nil next-pc (cddr pc)))
 		      ;; remove branch no-ops.
 		      ((and (branch-instruction-label i t)
 			    (label-here-p (branch-instruction-label i t)
@@ -2455,7 +2460,7 @@
 	 (t (case (instruction-is i)
 	      ((nil :call)
 	       (return nil))
-	      ((:into))
+	      ((:into :clc :stc :cld :std))
 	      ((:jnz :je :jne :jz))
 	      ((:outb)
 	       (setf free-so-far
@@ -2541,7 +2546,6 @@
 		     (multiple-value-call #'encoded-subtypep
 		       (values-list (binding-store-type binding))
 		       (type-specifier-encode '(or integer character))))
-		(warn "for ecX: ~S" binding)
 		:ecx)
 	       ((not (null free-registers-no-ecx))
 		(first free-registers-no-ecx))