[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-serv27181

Modified Files:
	los0-gc.lisp 
Log Message:
Debugging tweaks: Don't trigger-newspace when *gc-running*. Added
function report-lispval.

Date: Wed Jan 26 05:49:24 2005
Author: ffjeld

Index: movitz/losp/los0-gc.lisp
diff -u movitz/losp/los0-gc.lisp:1.46 movitz/losp/los0-gc.lisp:1.47
--- movitz/losp/los0-gc.lisp:1.46	Tue Jan 25 05:56:14 2005
+++ movitz/losp/los0-gc.lisp	Wed Jan 26 05:49:24 2005
@@ -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.46 2005/01/25 13:56:14 ffjeld Exp $
+;;;; $Id: los0-gc.lisp,v 1.47 2005/01/26 13:49:24 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -102,40 +102,41 @@
 
 (defun trigger-full-newspace (free-space)
   "Make it so that there's only free-space words left before newspace is full."
-  (let ((trigger (if (consp *gc-trigger*)
-		     (pop *gc-trigger*)
-		   *gc-trigger*)))
-    (when trigger
-      (macrolet
-	  ((do-it ()
-	     `(with-inline-assembly (:returns :nothing)
-	       retry
-		(:compile-form (:result-mode :eax) (+ free-space trigger))
-		(:locally (:movl (:edi (:edi-offset nursery-space)) :edx))
-		(:testl ,(logxor #xffffffff
-				 (* #xfff movitz:+movitz-fixnum-factor+))
-			:eax)
-		(:jnz '(:sub-program () (:int 64)))
-		(:addl 4 :eax)
-		(:andl -8 :eax)
-		(:movl (:edx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::num-elements))
-		       :ecx)
-		(:subl :eax :ecx)
-		(:movl (:edx 2) :ebx)
-		(:cmpl :ecx :ebx)
-		(:jc '(:sub-program ()
-		       ;; Current newspace was too full, so trigger a GC.
-		       (:int 113)
-		       (:jmp 'retry)))
-		(:movl :ecx (:edx 2))
-		(:addl 8 :ebx)
-	       fill-loop
-		(:movl :edi (:edx :ebx -6))
-		(:addl 4 :ebx)
-		(:cmpl :ebx :ecx)
-		(:ja 'fill-loop)
-		)))
-	(do-it)))))
+  (unless *gc-running*
+    (let ((trigger (if (consp *gc-trigger*)
+		       (pop *gc-trigger*)
+		     *gc-trigger*)))
+      (when trigger
+	(macrolet
+	    ((do-it ()
+	       `(with-inline-assembly (:returns :nothing)
+		 retry
+		  (:compile-form (:result-mode :eax) (+ free-space trigger))
+		  (:locally (:movl (:edi (:edi-offset nursery-space)) :edx))
+		  (:testl ,(logxor #xffffffff
+				   (* #xfff movitz:+movitz-fixnum-factor+))
+			  :eax)
+		  (:jnz '(:sub-program () (:int 64)))
+		  (:addl 4 :eax)
+		  (:andl -8 :eax)
+		  (:movl (:edx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::num-elements))
+			 :ecx)
+		  (:subl :eax :ecx)
+		  (:movl (:edx 2) :ebx)
+		  (:cmpl :ecx :ebx)
+		  (:jc '(:sub-program ()
+			 ;; Current newspace was too full, so trigger a GC.
+			 (:int 113)
+			 (:jmp 'retry)))
+		  (:movl :ecx (:edx 2))
+		  (:addl 8 :ebx)
+		 fill-loop
+		  (:movl :edi (:edx :ebx -6))
+		  (:addl 4 :ebx)
+		  (:cmpl :ebx :ecx)
+		  (:ja 'fill-loop)
+		  )))
+	  (do-it))))))
   
 
 (define-primitive-function los0-cons-pointer ()
@@ -156,7 +157,7 @@
 	    (:ja '(:sub-program (probe-failed)
 		   (:int 113)
 		   (:int 63)))
-	    (:movl :edi (:edx :ebx 8 ,movitz:+other-type-offset+))
+	    (:movl #xabbabee3 (:edx :ebx 8 ,movitz:+other-type-offset+)) ; a recognizable illegal value?
 	    (:leal (:edx :ebx 8) :eax)
 	    (:ret))))
     (do-it)))
@@ -405,6 +406,7 @@
 				 (break "Seeing old object in values-vector: ~Z" x))
 			       x)
 			     #x38 #xb8)
+	    #+ignore
 	    (let* ((stack (%run-time-context-slot 'muerte::stack-vector))
 		   (stack-start (- (length stack) (muerte::current-control-stack-depth))))
 	      (do ((i 0 (+ i 3)))
@@ -417,9 +419,6 @@
 			   (+ (object-location stack)
 			      offender-index 2)
 			   (aref a (+ i 2))))))
-	      (loop for x from 0 to #xa0000
-		  do (when (= #x19a04e (memref x 0 :type :unsigned-byte32))
-		       (warn "Seeing foo at ~S." x)))
 	      (loop for i from stack-start below (length stack)
 		  as o = (aref stack i)
 		  do (when (and (typep o 'pointer)
@@ -433,6 +432,7 @@
 	  (format t "Old space [~Z]: ~/muerte:pprint-clumps/, new space [~Z]: ~
 ~/muerte:pprint-clumps/, freed: ~/muerte:pprint-clumps/.~%"
 		  oldspace old-size newspace new-size (- old-size new-size))))
+
       (initialize-space oldspace)
       (fill oldspace #x13 :start 2)
       ;; (setf *gc-stack2* *gc-stack*)
@@ -471,3 +471,16 @@
 			   (+ 4 (object-location nursery) (space-fresh-pointer nursery))))
 	(map-stack-vector #'searcher nil (current-stack-frame))))
     results))
+
+(defun report-lispval (lispval &optional breakp newspace)
+  (let* ((location (truncate lispval 4))
+	 (newspace (or newspace (%run-time-context-slot 'muerte::nursery-space)))
+	 (oldspace (space-other newspace)))
+    (cond
+     ((location-in-object-p newspace location)
+      (format t "#x~X is in newspace ~Z." lispval newspace))
+     ((location-in-object-p oldspace location)
+      (funcall (if breakp 'break 'warn) "#x~X is in oldspace ~Z." lispval oldspace))
+     (t (funcall (if breakp 'break 'warn) "#x~X is neither old nor new?" lispval))))
+  (values))
+