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

Modified Files:
	los0-gc.lisp 
Log Message:
Changed the GC messages a bit, and added the feature of polling the
keyboard for ESC (if pressed, break) after each GC stop-and-copy cycle.

Date: Tue Jul 13 06:02:45 2004
Author: ffjeld

Index: movitz/losp/los0-gc.lisp
diff -u movitz/losp/los0-gc.lisp:1.24 movitz/losp/los0-gc.lisp:1.25
--- movitz/losp/los0-gc.lisp:1.24	Mon Jul 12 19:38:27 2004
+++ movitz/losp/los0-gc.lisp	Tue Jul 13 06:02:45 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.24 2004/07/13 02:38:27 ffjeld Exp $
+;;;; $Id: los0-gc.lisp,v 1.25 2004/07/13 13:02:45 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -247,8 +247,12 @@
     (setf (exception-handler 113)
       (lambda (exception interrupt-frame)
 	(declare (ignore exception interrupt-frame))
-	(format t "~&;; Handling out-of-memory exception..")
-	(stop-and-copy)))
+	(format t "~&;; GC.. ")
+	(stop-and-copy)
+	;; This is  a nice opportunity to poll the keyboard..
+	(case (muerte.x86-pc.keyboard:poll-char)
+	  ((#\esc)
+	   (break "Los0 GC keyboard poll.")))))
     (let ((conser (symbol-value 'los0-fast-cons)))
       (check-type conser vector)
       (setf (%run-time-context-slot 'muerte::fast-cons)
@@ -365,7 +369,7 @@
 			   (vector-push (object-location x) *x*)
 			   (vector-push (object-location fw) *x*)
 			   fw))))
-		    (t (let ((forwarded-x (memref (object-location x) 0 1 :lisp)))
+		    (t (let ((forwarded-x (memref (object-location x) 0 0 :lisp)))
 			 (if (object-in-space-p newspace forwarded-x)
 			     (progn
 			       (assert (eq (object-tag forwarded-x)
@@ -374,7 +378,7 @@
 			   (let ((forward-x (shallow-copy x)))
 			     (when (typep x 'muerte::bignum)
 			       (assert (= x forward-x)))
-			     (setf (memref (object-location x) 0 1 :lisp) forward-x)
+			     (setf (memref (object-location x) 0 0 :lisp) forward-x)
 			     forward-x)))))))))
 	;; Scavenge roots
 	(map-heap-words evacuator 0 (+ (malloc-buffer-start)
@@ -404,7 +408,7 @@
 	;; GC completed, oldspace is evacuated.
 	(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: ~/muerte:pprint-clumps/, new space: ~
 ~/muerte:pprint-clumps/, freed: ~/muerte:pprint-clumps/.~%"
 		  old-size new-size (- old-size new-size)))
 	(initialize-space oldspace))))