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

[Frode Vatvedt Fjeld]

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

Modified Files:
	compiler.lisp 
Log Message:
Some tuning of the mess that is forwarding-bindings and register allocaiton.

Date: Fri Nov 19 00:49:56 2004
Author: ffjeld

Index: movitz/compiler.lisp
diff -u movitz/compiler.lisp:1.108 movitz/compiler.lisp:1.109
--- movitz/compiler.lisp:1.108	Thu Nov 18 18:58:35 2004
+++ movitz/compiler.lisp	Fri Nov 19 00:49:53 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.108 2004/11/18 17:58:35 ffjeld Exp $
+;;;; $Id: compiler.lisp,v 1.109 2004/11/18 23:49:53 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -2756,13 +2756,13 @@
   (let* ((count-init-pc (gethash binding var-counts))
 	 (count (car count-init-pc))
 	 (init-pc (cdr count-init-pc)))
+    ;; (warn "b ~S: count: ~D, init-pc: ~{~&~A~}" binding count init-pc)
     (cond
      ((binding-lended-p binding)
       ;; We can't lend a register.
       (values nil :never))
      ((and (= 1 count)
 	   init-pc)
-      ;; (warn "b ~S: count: ~D, init-pc: ~{~&~A~}" binding count init-pc)
       (assert (instruction-is (first init-pc) :init-lexvar))
       (destructuring-bind (init-binding &key init-with-register init-with-type
 					     protect-registers protect-carry)
@@ -2773,7 +2773,7 @@
 		(find-if (lambda (i)
 			   (and (not (instruction-is i :init-lexvar))
 				(member binding (find-read-bindings i)
-					:test #'eq)))
+					:test #'eq #+ignore #'binding-eql)))
 			 (cdr init-pc)
 			 #-sbcl :end #-sbcl 15))
 	       (binding-destination (third load-instruction))
@@ -2836,6 +2836,9 @@
 		   (assert (not (cdr count-init-pc)))
 		   (setf (cdr count-init-pc) init-pc))
 		 (unless storep
+		   (unless (eq binding (binding-target binding))
+		     ;; (break "ewfew: ~S" (gethash (binding-target binding) var-counter))
+		     (take-note-of-binding (binding-target binding)))
 		   (incf (car count-init-pc))))
 	       #+ignore
 	       (when (typep binding 'forwarding-binding)
@@ -2878,7 +2881,7 @@
 			     (when init-with-register
 			       (take-note-of-binding binding t pc)
 			       (when (and (typep init-with-register 'binding)
-					  #+ignore (not (typep binding 'forwarding-binding)))
+					  (not (typep binding 'forwarding-binding))) ; XXX
 				 (take-note-of-binding init-with-register)))))
 			  (t (mapcar #'take-note-of-binding 
 				     (find-read-bindings instruction))
@@ -6090,7 +6093,7 @@
 				 (and (typep binding 'forwarding-binding)
 				      (recursive-located-p (forwarding-binding-target b))))))
 		    (recursive-located-p binding)))
-	(warn "Unused variable: ~S." (binding-name binding))))
+	#+ignore (warn "Unused variable: ~S." (binding-name binding))))
      ((typep binding 'forwarding-binding)
       ;; No need to do any initialization because the target will be initialized.
       (assert (not (binding-lended-p binding)))
@@ -6409,8 +6412,8 @@
       (when (and (bindingp destination)
 		 (binding-lended-p destination))
 	(warn "Add for lend0: ~S" destination))
-      (let ((loc0 (new-binding-location term0 frame-map :default nil))
-	    (loc1 (new-binding-location term1 frame-map :default nil)))
+      (let ((loc0 (new-binding-location (binding-target term0) frame-map :default nil))
+	    (loc1 (new-binding-location (binding-target term1) frame-map :default nil)))
 ;;;	(warn "add: ~A" instruction)
 ;;;	(warn "add for: ~S is ~A, from ~A/~A and ~A/~A."
 ;;;	      destination result-type
@@ -6455,7 +6458,7 @@
 ;;;		  loc1 term1
 ;;;		  (type-specifier-singleton type0)
 ;;;		  (eq loc1 destination))
-;;;	     (warn "ADDI: ~S" instruction)
+;;;	    (warn "ADDI: ~S" instruction)
 	    (append (cond
 		     ((and (eq :eax loc0) (eq :ebx loc1))
 		      nil)
@@ -6511,21 +6514,25 @@
 	(rotatef x y)
 	(rotatef x-type y-type)
 	(rotatef x-singleton y-singleton))
-      (warn "eql ~S ~S" x-singleton y-singleton)
-      (cond
-       ((and x-singleton y-singleton)
-	(break "Constant EQL: ~S ~S" (car x-singleton) (car y-singleton)))
-       ((or (movitz-subtypep x-type 'fixnum)
-	    (movitz-subtypep x-type 'character)
-	    (movitz-subtypep y-type 'fixnum)
-	    (movitz-subtypep y-type 'character))
-	(break "EQL that is EQ."))
-       (t (append (make-load-lexical x :eax funobj nil frame-map)
-		  (make-load-lexical y :ebx funobj nil frame-map)
-		  (let ((eql-done (gensym "eql-done-")))
-		    `((:cmpl :eax :ebx)
-		      (:je ',eql-done)
-		      (,*compiler-global-segment-prefix*
-		       :movl (:edi ,(global-constant-offset 'complicated-eql)) :esi)
-		      (:call (:esi ,(bt:slot-offset 'movitz-funobj 'code-vector%2op)))
-		      ,eql-done))))))))
+      (let ((x-loc (new-binding-location (binding-target x) frame-map :default nil))
+	    (y-loc (new-binding-location (binding-target y) frame-map :default nil)))
+	(warn "eql ~S/~S ~S/~S"
+	      x x-loc
+	      y y-loc)
+	(cond
+	 ((and x-singleton y-singleton)
+	  (break "Constant EQL: ~S ~S" (car x-singleton) (car y-singleton)))
+	 ((or (movitz-subtypep x-type 'fixnum)
+	      (movitz-subtypep x-type 'character)
+	      (movitz-subtypep y-type 'fixnum)
+	      (movitz-subtypep y-type 'character))
+	  (break "EQL that is EQ."))
+	 (t (append (make-load-lexical x :eax funobj nil frame-map)
+		    (make-load-lexical y :ebx funobj nil frame-map)
+		    (let ((eql-done (gensym "eql-done-")))
+		      `((:cmpl :eax :ebx)
+			(:je ',eql-done)
+			(,*compiler-global-segment-prefix*
+			 :movl (:edi ,(global-constant-offset 'complicated-eql)) :esi)
+			(:call (:esi ,(bt:slot-offset 'movitz-funobj 'code-vector%2op)))
+			,eql-done)))))))))