[movitz-cvs] CVS update: movitz/losp/muerte/scavenge.lisp

[Frode Vatvedt Fjeld]

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

Modified Files:
	scavenge.lisp 
Log Message:
Fixing dynamic control transfers, primarily to handle the
stack-allocated funobjs, but there seems to be a number of (other)
bugs here too. It's not quite working yet, though.

Date: Tue Jan  4 17:54:28 2005
Author: ffjeld

Index: movitz/losp/muerte/scavenge.lisp
diff -u movitz/losp/muerte/scavenge.lisp:1.38 movitz/losp/muerte/scavenge.lisp:1.39
--- movitz/losp/muerte/scavenge.lisp:1.38	Mon Jan  3 12:53:47 2005
+++ movitz/losp/muerte/scavenge.lisp	Tue Jan  4 17:54:27 2005
@@ -1,6 +1,6 @@
 ;;;;------------------------------------------------------------------
 ;;;; 
-;;;;    Copyright (C) 2003-2004, 
+;;;;    Copyright (C) 2003-2005, 
 ;;;;    Department of Computer Science, University of Tromso, Norway.
 ;;;; 
 ;;;;    For distribution policy, see the accompanying file COPYING.
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Mon Mar 29 14:54:08 2004
 ;;;;                
-;;;; $Id: scavenge.lisp,v 1.38 2005/01/03 11:53:47 ffjeld Exp $
+;;;; $Id: scavenge.lisp,v 1.39 2005/01/04 16:54:27 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -204,10 +204,11 @@
 				    (+ dit-frame (dit-frame-index :ecx)))))
 		    ;; 2. Pop to (dit-)frame's CASF
 		    (setf nether-frame dit-frame
-			  frame (dit-frame-casf stack frame))
-		    (let ((casf-funobj (funcall function (stack-frame-funobj stack frame) frame))
+			  frame casf-frame #+ignore (dit-frame-casf stack frame))
+		    (let ((eip-location (dit-frame-ref stack dit-frame :eip :location))
+			  (interrupted-esp (dit-frame-esp stack dit-frame))
 			  (interrupted-ebp (dit-frame-ref stack dit-frame :ebp))
-			  (interrupted-esp (dit-frame-esp stack dit-frame)))
+			  (casf-funobj (funcall function (stack-frame-funobj stack frame) frame)))
 		      (cond
 		       #+ignore
 		       ((eq nil casf-funobj)
@@ -218,23 +219,21 @@
 			(let ((casf-code-vector (scavenge-funobj-code-vector casf-funobj)))
 			  ;; 3. Scavenge the interrupted frame, according to one of i. ii. or iii.
 			  (cond
-			   ((< interrupted-ebp interrupted-esp)
+			   ((eq nil interrupted-ebp)
 			    (cond
-			     ((location-in-object-p casf-code-vector
-						    (dit-frame-ref stack dit-frame :eip :location))
-			      (warn "DIT at throw situation, in target EIP=~S"
+			     ((location-in-object-p casf-code-vector eip-location)
+			      (warn "DIT at throw situation, in target ~S at ~S"
+				    casf-funobj
 				    (dit-frame-ref stack dit-frame :eip :unsigned-byte32))
 			      (map-region function interrupted-esp frame))
-			     ((location-in-object-p (scavenge-funobj-code-vector (dit-frame-ref stack
-												dit-frame
-												:scratch1))
-						    (dit-frame-ref stack dit-frame :eip :location))
-			      (warn "DIT at throw situation, in thrower EIP=~S"
-				    (dit-frame-ref stack dit-frame :eip :unsigned-byte32))
-			      (map-region function interrupted-esp frame))
-			     (t (error "DIT with EBP<ESP, EBP=~S, ESP=~S"
-				       interrupted-ebp
-				       interrupted-esp))))
+			     ((location-in-object-p (%run-time-context-slot 'dynamic-jump-next)
+						    eip-location)
+			      (warn "DIT at throw situation, in dynamic-jump-next.")
+			      (let ((dynamic-env (dit-frame-ref stack dit-frame :dynamic-env)))
+				(assert (< dynamic-env frame))
+				(map-region function dynamic-env frame)))
+			     (t (error "Unknown throw situation with EBP=~S, ESP=~S"
+				       interrupted-ebp interrupted-esp))))
 			   ((location-in-object-p casf-code-vector
 						  (dit-frame-ref stack dit-frame :eip :location))
 			    (cond
@@ -295,7 +294,8 @@
 			    (map-region function (+ interrupted-esp 1) frame)
 			    (setf next-frame frame
 				  next-nether-frame (+ interrupted-esp 1 -2))))))
-		       (t (error "DIT-frame interrupted unknown CASF funobj: ~S" casf-funobj))))))
+		       (t (error "DIT-frame interrupted unknown CASF funobj: ~Z, CASF ~S"
+				 casf-funobj casf-frame))))))
 		 (t (error "Don't know how to scavenge across frame ~S of kind ~S." frame funobj)))))))
   (values))