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

[Frode Vatvedt Fjeld]

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

Modified Files:
	compiler.lisp 
Log Message:
Fix detection of unused variables.

Date: Wed Nov 24 11:02:43 2004
Author: ffjeld

Index: movitz/compiler.lisp
diff -u movitz/compiler.lisp:1.116 movitz/compiler.lisp:1.117
--- movitz/compiler.lisp:1.116	Tue Nov 23 17:10:17 2004
+++ movitz/compiler.lisp	Wed Nov 24 11:02:42 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.116 2004/11/23 16:10:17 ffjeld Exp $
+;;;; $Id: compiler.lisp,v 1.117 2004/11/24 10:02:42 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -2772,7 +2772,7 @@
    This function is factored out from assign-bindings."
   (let* ((count-init-pc (gethash binding var-counts))
 	 (count (car count-init-pc))
-	 (init-pc (cdr count-init-pc)))
+	 (init-pc (second count-init-pc)))
     ;; (warn "b ~S: count: ~D, init-pc: ~{~&~A~}" binding count init-pc)
     (cond
      ((binding-lended-p binding)
@@ -2845,13 +2845,20 @@
   (check-type function-env function-env)
   ;; (print-code 'discover code)
   (let ((var-counter (make-hash-table :test #'eq :size 40)))
-    (labels ((take-note-of-binding (binding &optional storep init-pc)
+    (labels ((record-binding-used (binding)
 	       (let ((count-init-pc (or (gethash binding var-counter)
 					(setf (gethash binding var-counter)
-					  (cons 0 nil)))))
+					  (list 0 nil t)))))
+		 (setf (third count-init-pc) t)
+		 (when (typep binding 'forwarding-binding)
+		   (record-binding-used (forwarding-binding-target binding)))))
+	     (take-note-of-binding (binding &optional storep init-pc)
+	       (let ((count-init-pc (or (gethash binding var-counter)
+					(setf (gethash binding var-counter)
+					  (list 0 nil t)))))
 		 (when init-pc
-		   (assert (not (cdr count-init-pc)))
-		   (setf (cdr count-init-pc) init-pc))
+		   (assert (not (second count-init-pc)))
+		   (setf (second count-init-pc) init-pc))
 		 (unless storep
 		   (unless (eq binding (binding-target binding))
 		     ;; (break "ewfew: ~S" (gethash (binding-target binding) var-counter))
@@ -2902,6 +2909,8 @@
 				 (take-note-of-binding init-with-register)))))
 			  (t (mapcar #'take-note-of-binding 
 				     (find-read-bindings instruction))
+			     (mapcar #'record-binding-used ; This is just concerning "unused variable"
+				     (find-used-bindings instruction)) ; warnings!
 			     (let ((store-binding (find-written-binding-and-type instruction)))
 			       (when store-binding
 				 (take-note-of-binding store-binding t)))
@@ -2953,13 +2962,13 @@
 				    (prog1 nil ; may need lending-cons
 				      (setf (new-binding-location binding frame-map)
 					`(:argument-stack ,(function-argument-argnum binding)))))
-				   ((not (plusp (or (car (gethash binding var-counts)) 0)))
-				    (prog1 t
-				      (unless (or (movitz-env-get variable 'ignore nil env nil)
-						  (movitz-env-get variable 'ignorable nil env nil)
-						  (typep binding 'hidden-rest-function-argument))
-					(warn "Unused variable: ~S"
-					      (binding-name binding))))))
+				   ((unless (or (movitz-env-get variable 'ignore nil env nil)
+						(movitz-env-get variable 'ignorable nil env nil)
+						(typep binding 'hidden-rest-function-argument)
+						(third (gethash binding var-counts)))
+				      (warn "Unused variable: ~S"
+					    (binding-name binding))))
+				   ((not (plusp (or (car (gethash binding var-counts)) 0)))))
 			   collect binding))
 		      (bindings-fun-arg-sorted
 		       (when (eq env function-env)
@@ -2987,7 +2996,7 @@
 				      (located-binding
 				       (let* ((count-init (gethash b var-counts))
 					      (count (car count-init))
-					      (init-pc (cdr count-init)))
+					      (init-pc (second count-init)))
 					 (if (not (and count init-pc))
 					     50
 					   (truncate
@@ -5924,6 +5933,9 @@
 (defvar *extended-code-find-read-binding*
     (make-hash-table :test #'eq))
 
+(defvar *extended-code-find-used-bindings*
+    (make-hash-table :test #'eq))
+
 (defmacro define-find-read-bindings (name lambda-list &body body)
   (let ((defun-name (intern
 		     (with-standard-io-syntax
@@ -5935,6 +5947,28 @@
 	     (cdr instruction)
 	   , at body)))))
 
+(defmacro define-find-used-bindings (name lambda-list &body body)
+  (let ((defun-name (intern
+		     (with-standard-io-syntax
+		       (format nil "~A-~A" 'find-used-bindings name)))))
+    `(progn
+       (setf (gethash ',name *extended-code-find-used-bindings*) ',defun-name)
+       (defun ,defun-name (instruction)
+	 (destructuring-bind ,lambda-list
+	     (cdr instruction)
+	   , at body)))))
+
+(defun find-used-bindings (extended-instruction)
+  "Return zero, one or two bindings that this instruction reads."
+  (when (listp extended-instruction)
+    (let* ((operator (car extended-instruction))
+	   (finder (or (gethash operator *extended-code-find-used-bindings*)
+		       (gethash operator *extended-code-find-read-binding*))))
+      (when finder
+	(let ((result (funcall finder extended-instruction)))
+	  (check-type result list "a list of read bindings")
+	  result)))))
+
 (defun find-read-bindings (extended-instruction)
   "Return zero, one or two bindings that this instruction reads."
   (when (listp extended-instruction)
@@ -6417,6 +6451,11 @@
 		  x))
 	      (list term0 term1)
 	      ))))
+
+(define-find-used-bindings :add (term0 term1 destination)
+  (if (bindingp destination)
+      (list term0 term1 destination)
+    (list term0 term1)))
 
 (define-find-read-bindings :add (term0 term1 destination)
   (declare (ignore destination))