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

[Frode Vatvedt Fjeld]

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

Modified Files:
	compiler.lisp 
Log Message:
More tuning of type inference.

Date: Sat Aug 14 10:47:04 2004
Author: ffjeld

Index: movitz/compiler.lisp
diff -u movitz/compiler.lisp:1.93 movitz/compiler.lisp:1.94
--- movitz/compiler.lisp:1.93	Thu Aug 12 10:25:06 2004
+++ movitz/compiler.lisp	Sat Aug 14 10:47:04 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.93 2004/08/12 17:25:06 ffjeld Exp $
+;;;; $Id: compiler.lisp,v 1.94 2004/08/14 17:47:04 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -415,33 +415,7 @@
 		   (cond
 		    (thunk
 		     (assert (some #'bindingp thunk-args))
-;;;		     (assert (notany (lambda (arg)
-;;;				       (and (bindingp arg)
-;;;					    (binding-eql arg binding)))
-;;;				     thunk-args)
-;;;			 () "A thunk on itself for ~S?" binding)
 		     (push (cons thunk thunk-args) (type-analysis-thunks analysis)))
-;;;		    ((typep binding 'function-argument)
-;;;		     (setf (type-analysis-encoded-type analysis)
-;;;		       (multiple-value-list
-;;;			(type-specifier-encode (etypecase binding
-;;;						 (rest-function-argument 'list)
-;;;						 (supplied-p-function-argument 'boolean)
-;;;						 (function-argument t))))))
-;;;		    ((and (consp type) (eq 'binding-type (car type)))
-;;;		     (break "Got binding-type.")
-;;;		     (let ((target-binding (binding-target (cadr type))))
-;;;		       (cond
-;;;			((eq binding target-binding))
-;;;			((typep binding 'constant-object-binding)
-;;;			 (setf (type-analysis-encoded-type analysis)
-;;;			   (multiple-value-list
-;;;			    (multiple-value-call
-;;;				#'encoded-types-or 
-;;;			      (values-list (type-analysis-encoded-type analysis))
-;;;			      (member-type-encode (constant-object target-binding))))))
-;;;			(t (pushnew target-binding (type-analysis-binding-types analysis))
-;;;			   ))))
 		    ((and (bindingp type)
 			  (binding-eql type binding))
 		     (break "got binding type")
@@ -451,10 +425,7 @@
 			  (multiple-value-call
 			      #'encoded-types-or 
 			    (values-list (type-analysis-encoded-type analysis))
-			    (type-specifier-encode type)))))))
-		 #+ignore
-		 (when (typep binding 'forwarding-binding)
-		   (analyze-store (forwarding-binding-target binding) type thunk thunk-args)))
+			    (type-specifier-encode type))))))))
 	       (analyze-code (code)
 		 (dolist (instruction code)
 		   (when (listp instruction)
@@ -478,10 +449,8 @@
 	(flet ((resolve-thunks ()
 		 (loop with more-thunks-p = t
 		     repeat 20
-		     finally (return t)
-		     do (unless more-thunks-p
-			  (return nil))
-			(setf more-thunks-p nil)
+		     while more-thunks-p
+		     do (setf more-thunks-p nil)
 			(maphash (lambda (binding analysis)
 				   (declare (ignore binding))
 				   (setf (type-analysis-thunks analysis)
@@ -504,8 +473,8 @@
 									 thunk-args)))))))
 					 (setf more-thunks-p t))))
 				 binding-usage))))
-	  (when (and (resolve-thunks)
-		     *compiler-trust-user-type-declarations-p*)
+	  (resolve-thunks)
+	  (when *compiler-trust-user-type-declarations-p*
 	    ;; For each unresolved binding, just use the declared type.
 	    (maphash (lambda (binding analysis)
 		       (declare (ignore binding))