[movitz-cvs] CVS update: movitz/losp/los0-gc.lisp
Frode Vatvedt Fjeld
ffjeld at common-lisp.net
Fri Jul 23 15:26:52 UTC 2004
Update of /project/movitz/cvsroot/movitz/losp
In directory common-lisp.net:/tmp/cvs-serv28449
Modified Files:
los0-gc.lisp
Log Message:
Added and improved debugging instrumentation of this GC.
Date: Fri Jul 23 08:26:51 2004
Author: ffjeld
Index: movitz/losp/los0-gc.lisp
diff -u movitz/losp/los0-gc.lisp:1.30 movitz/losp/los0-gc.lisp:1.31
--- movitz/losp/los0-gc.lisp:1.30 Tue Jul 20 16:47:50 2004
+++ movitz/losp/los0-gc.lisp Fri Jul 23 08:26:51 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.30 2004/07/20 23:47:50 ffjeld Exp $
+;;;; $Id: los0-gc.lisp,v 1.31 2004/07/23 15:26:51 ffjeld Exp $
;;;;
;;;;------------------------------------------------------------------
@@ -20,6 +20,10 @@
(defvar *gc-quiet* nil)
(defvar *gc-running* nil)
+(defvar *gc-break* nil)
+(defvar *gc-trigger* nil)
+(defvar *gc-consitency-check* t)
+
(defun make-space (location size)
"Make a space vector at a fixed location."
@@ -100,6 +104,39 @@
(:ret))))
(do-it)))
+
+(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)
+ (: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)
+ (: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-get-cons-pointer ()
"Return in EAX the next object location with space for EAX words, with tag 6.
Preserve ECX."
@@ -252,16 +289,18 @@
(when *gc-running*
(let ((muerte::*error-no-condition-for-debugger* t))
(error "Recursive GC triggered.")))
- (let ((*gc-running t))
+ (let ((*gc-running* t))
(unless *gc-quiet*
(format t "~&;; GC.. "))
(stop-and-copy)
- (loop ; This is a nice opportunity to poll the keyboard..
- (case (muerte.x86-pc.keyboard:poll-char)
- ((#\esc)
- (break "Los0 GC keyboard poll."))
- ((nil)
- (return))))))))
+ (if *gc-break*
+ (break "GC break.")
+ (loop ; This is a nice opportunity to poll the keyboard..
+ (case (muerte.x86-pc.keyboard:poll-char)
+ ((#\esc)
+ (break "Los0 GC keyboard poll."))
+ ((nil)
+ (return)))))))))
(let* ((actual-duo-space (or duo-space
(allocate-duo-space (* kb-size #x100))))
(last-location (object-location (cons 1 2))))
@@ -289,12 +328,12 @@
(values))
(defun object-in-space-p (space object)
- (check-type space vector-u32)
+ (check-type space (simple-array (unsigned-byte 32) 1))
(and (typep object 'pointer)
- (< (object-location space)
- (object-location object)
- (+ (object-location space)
- (array-dimension space 0)))))
+ (<= (+ 2 (object-location space))
+ (object-location object)
+ (+ 1 (object-location space)
+ (array-dimension space 0)))))
(defun tenure ()
(install-old-consing)
@@ -359,14 +398,6 @@
(cond
((not (object-in-space-p oldspace x))
x)
- #+ignore ((typep x 'bignum)
- (let ((fwi (position (object-location x) *x* :test #'eq)))
- (if fwi
- (muerte::%word-offset (aref *x* (1+ fwi)) 6)
- (let ((fw (shallow-copy x)))
- (vector-push (object-location x) *x*)
- (vector-push (object-location fw) *x*)
- fw))))
(t (let ((forwarded-x (memref (object-location x) 0 0 :lisp)))
(if (object-in-space-p newspace forwarded-x)
(progn
@@ -374,8 +405,9 @@
(object-tag x)))
forwarded-x)
(let ((forward-x (shallow-copy x)))
- (let ((a *x*))
- (when (typep x 'muerte::pointer)
+ (when (and (typep x 'muerte::pointer)
+ *gc-consitency-check*)
+ (let ((a *x*))
(vector-push (%object-lispval x) a)
(vector-push (memref (object-location x) 0 0 :unsigned-byte32) a)
(assert (vector-push (%object-lispval forward-x) a))))
@@ -397,30 +429,32 @@
(setf scan-pointer fresh-pointer))
;; Consistency check..
- (let ((a *x*))
- ;; First, restore the state of old-space
- (do ((i 0 (+ i 3)))
- ((>= i (length a)))
- (let ((old (%lispval-object (aref a i)))
- (old-class (aref a (+ i 1))))
- (setf (memref (object-location old) 0 0 :unsigned-byte32) old-class)))
- ;; Then, check that each migrated object is equalp to its new self.
- (do ((i 0 (+ i 3)))
- ((>= i (length a)))
- (let ((old (%lispval-object (aref a i)))
- (new (%lispval-object (aref a (+ i 2)))))
- (unless (and (object-in-space-p newspace new)
- (object-in-space-p oldspace old)
- (objects-equalp old new))
- (let ((*old* old)
- (*new* new)
- (*old-class* (aref a (+ i 1))))
- (declare (special *old* *new* *old-class*))
- (error "GC consistency check failed:
+ (when *gc-consitency-check*
+ (let ((a *x*))
+ ;; First, restore the state of old-space
+ (do ((i 0 (+ i 3)))
+ ((>= i (length a)))
+ (let ((old (%lispval-object (aref a i)))
+ (old-class (aref a (+ i 1))))
+ (setf (memref (object-location old) 0 0 :unsigned-byte32) old-class)))
+ ;; Then, check that each migrated object is equalp to its new self.
+ (do ((i 0 (+ i 3)))
+ ((>= i (length a)))
+ (let ((old (%lispval-object (aref a i)))
+ (new (%lispval-object (aref a (+ i 2)))))
+ (unless (and (object-in-space-p newspace new)
+ (object-in-space-p oldspace old)
+ (objects-equalp old new))
+ (let ((*old* old)
+ (*new* new)
+ (*old-class* (aref a (+ i 1))))
+ (declare (special *old* *new* *old-class*))
+ (with-simple-restart (continue "Ignore failed GC consistency check.")
+ (error "GC consistency check failed:
old object: ~Z: ~S
new object: ~Z: ~S
oldspace: ~Z, newspace: ~Z, i: ~D"
- old old new new oldspace newspace i))))))
+ old old new new oldspace newspace i))))))))
;; GC completed, oldspace is evacuated.
(unless *gc-quiet*
@@ -429,5 +463,6 @@
(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))))
+ (initialize-space oldspace)
+ (fill oldspace #x3 :start 2))))
(values))
More information about the Movitz-cvs
mailing list