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

Modified Files:
	los0-gc.lisp 
Log Message:
Re-working the stack discipline/scavenging strategy. Still not quite
there, but it seems close.

Date: Tue Jan 25 05:56:14 2005
Author: ffjeld

Index: movitz/losp/los0-gc.lisp
diff -u movitz/losp/los0-gc.lisp:1.45 movitz/losp/los0-gc.lisp:1.46
--- movitz/losp/los0-gc.lisp:1.45	Wed Dec  8 15:39:51 2004
+++ movitz/losp/los0-gc.lisp	Tue Jan 25 05:56:14 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:    Sat Feb 21 17:48:32 2004
 ;;;;                
-;;;; $Id: los0-gc.lisp,v 1.45 2004/12/08 23:39:51 ffjeld Exp $
+;;;; $Id: los0-gc.lisp,v 1.46 2005/01/25 13:56:14 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -109,6 +109,7 @@
       (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
@@ -121,6 +122,11 @@
 		       :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
@@ -138,7 +144,6 @@
   (macrolet
       ((do-it ()
 	 `(with-inline-assembly (:returns :multiple-values)
-	   retry
 	    (:locally (:cmpl 0 (:edi (:edi-offset atomically-continuation)))) ; Atomically?
 	    (:je '(:sub-program ()
 		   (:int 63)))		; This must be called inside atomically.
@@ -151,8 +156,8 @@
 	    (:ja '(:sub-program (probe-failed)
 		   (:int 113)
 		   (:int 63)))
-	    (:leal (:edx :ebx 8) :eax)
 	    (:movl :edi (:edx :ebx 8 ,movitz:+other-type-offset+))
+	    (:leal (:edx :ebx 8) :eax)
 	    (:ret))))
     (do-it)))
 
@@ -162,7 +167,6 @@
   (macrolet
       ((do-it ()
 	 `(with-inline-assembly (:returns :multiple-values)
-	   retry
 	    (:locally (:cmpl 0 (:edi (:edi-offset atomically-continuation)))) ; Atomically?
 	    (:je '(:sub-program ()
 		   (:int 63)))		; This must be called inside atomically.
@@ -174,7 +178,7 @@
 		   :ecx)
 	    (:ja '(:sub-program (commit-failed)
 		   (:int 113)
-		   (:jmp 'retry)))
+		   (:int 63)))
 	    (:movl :ecx (:edx 2))
 	    (:leal (:edx :ecx) :ecx)
 	    (:ret))))
@@ -190,7 +194,6 @@
 	    (:leal ((:ecx ,movitz:+movitz-fixnum-factor+)) :eax)
 	    (:ret)
 	   not-fixnum
-	   retry-cons
 	    (:locally (:movl ,(movitz::atomically-continuation-simple-pf 'box-u32-ecx)
 			     (:edi (:edi-offset atomically-continuation))))
 	    (:locally (:movl (:edi (:edi-offset nursery-space)) :edx))
@@ -211,7 +214,8 @@
 	    (:ret))))
     (do-it)))
 
-(defvar *gc-stack*)
+(defvar *gc-stack* nil)
+(defvar *gc-stack2* nil)
 
 (defun install-los0-consing (&key (context (current-run-time-context))
 				  (kb-size 1024)
@@ -401,23 +405,37 @@
 				 (break "Seeing old object in values-vector: ~Z" x))
 			       x)
 			     #x38 #xb8)
-	    (let* ((stack (%run-time-context-slot 'muerte::nursery-space))
+	    (let* ((stack (%run-time-context-slot 'muerte::stack-vector))
 		   (stack-start (- (length stack) (muerte::current-control-stack-depth))))
 	      (do ((i 0 (+ i 3)))
 		  ((>= i (length a)))
-		(when (find (aref a i) stack :start stack-start)
-		  (break "Seeing old object ~S in current stack!"
-			 (aref a i))))))))
-
+		(let* ((offender? (aref a i))
+		       (offender-index (position offender? stack :start stack-start)))
+		  (when offender-index
+		    (break "Seeing old object ~S in current stack at ~S, new is ~S"
+			   offender?
+			   (+ (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)
+				(location-in-object-p oldspace (object-location o)))
+		       (break "Seeing old (unmapped) object ~Z in stack at ~S."
+			      o (+ (object-location stack) i 2))))))))
       ;; GC completed, oldspace is evacuated.
       (unless *gc-quiet*
 	(let ((old-size (truncate (- (space-fresh-pointer oldspace) 2) 2))
 	      (new-size (truncate (- (space-fresh-pointer newspace) 2) 2)))
-	  (format t "Old space: ~/muerte:pprint-clumps/, new space: ~
+	  (format t "Old space [~Z]: ~/muerte:pprint-clumps/, new space [~Z]: ~
 ~/muerte:pprint-clumps/, freed: ~/muerte:pprint-clumps/.~%"
-		  old-size new-size (- old-size new-size))))
+		  oldspace old-size newspace new-size (- old-size new-size))))
       (initialize-space oldspace)
       (fill oldspace #x13 :start 2)
+      ;; (setf *gc-stack2* *gc-stack*)
       (setf *gc-stack* (muerte::copy-current-control-stack))
       (setf (fill-pointer *xx*) (fill-pointer *x*))
       (replace *xx* *x*)))