[movitz-cvs] CVS update: movitz/losp/los0-gc.lisp

[Frode Vatvedt Fjeld]

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

Modified Files:
	los0-gc.lisp 
Log Message:
The scavenging mapper function now also passes the referring location
as an argument to the mapped function.

Date: Wed Mar 31 11:36:29 2004
Author: ffjeld

Index: movitz/losp/los0-gc.lisp
diff -u movitz/losp/los0-gc.lisp:1.1 movitz/losp/los0-gc.lisp:1.2
--- movitz/losp/los0-gc.lisp:1.1	Mon Mar 29 09:35:45 2004
+++ movitz/losp/los0-gc.lisp	Wed Mar 31 11:36:29 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Sat Feb 21 17:48:32 2004
 ;;;;                
-;;;; $Id: los0-gc.lisp,v 1.1 2004/03/29 14:35:45 ffjeld Exp $
+;;;; $Id: los0-gc.lisp,v 1.2 2004/03/31 16:36:29 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -139,18 +139,25 @@
 	  (+ (object-location space)
 	     (array-dimension space 0)))))
 
-(defun report-nursery (x)
+(defun report-nursery (x location)
   "Write a message if x is inside newspace."
   (when (object-in-space-p (%run-time-context-slot 'nursery-space) x)
-    (format t "~&~Z: ~S: ~S" x (type-of x) x))
+    (format t "~&~Z: ~S: ~S from ~S" x (type-of x) x location))
   x)
 
-(defun report-inactive-space (x)
+(defun report-inactive-space (x location)
   "Check that x is not pointing into (what is presumably) oldspace."
   (when (object-in-space-p (space-other (%run-time-context-slot 'nursery-space)) x)
-    (break "~Z: ~S: ~S" x (type-of x) x))
+    (break "~Z: ~S: ~S from ~S" x (type-of x) x location))
   x)
 
+(defun location-finder (find-location)
+  (lambda (x location)
+    (when (location-in-object-p x find-location)
+      (break "The location ~S is in the object at ~Z referenced from location ~S."
+	     find-location x location))
+    x))
+
 (defun stop-and-copy ()
   (let* ((space0 (%run-time-context-slot 'nursery-space))
 	 (space1 (space-other space0)))
@@ -164,9 +171,11 @@
 	  (values space1 space0))
       ;; Ensure newspace is activated.
       (setf (%run-time-context-slot 'nursery-space) newspace)
+      ;; (assert (< #x200 (- (length newspace) (space-fresh-pointer newspace))))
       ;; Evacuate-oldspace is to be mapped over every potential pointer.
-      (flet ((evacuate-oldspace (x)
+      (flet ((evacuate-oldspace (x location)
 	       "If x is in oldspace, migrate it to newspace."
+	       (declare (ignore location))
 	       (if (not (object-in-space-p oldspace x))
 		   x
 		 (let ((forwarded-x (memref (object-location x) 0 1 :lisp)))