Update of /project/movitz/cvsroot/movitz/losp In directory common-lisp.net:/tmp/cvs-serv20090
Modified Files: los0-gc.lisp Log Message: When seeing if an object is already forwared during scavenge, be more careful about loading in the potential forwarding pointer. If it's not an actual forwarding pointer, we're not really allowed to load it in as a lispval.
Date: Thu Sep 2 11:33:06 2004 Author: ffjeld
Index: movitz/losp/los0-gc.lisp diff -u movitz/losp/los0-gc.lisp:1.34 movitz/losp/los0-gc.lisp:1.35 --- movitz/losp/los0-gc.lisp:1.34 Mon Aug 23 15:58:07 2004 +++ movitz/losp/los0-gc.lisp Thu Sep 2 11:33:06 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld frodef@acm.org ;;;; Created at: Sat Feb 21 17:48:32 2004 ;;;; -;;;; $Id: los0-gc.lisp,v 1.34 2004/08/23 13:58:07 ffjeld Exp $ +;;;; $Id: los0-gc.lisp,v 1.35 2004/09/02 09:33:06 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------
@@ -288,7 +288,7 @@ (let ((*standard-output* *terminal-io*)) (when *gc-running* (let ((muerte::*error-no-condition-for-debugger* t)) - (error "Recursive GC triggered."))) + (warn "Recursive GC triggered."))) (let ((*gc-running* t)) (unless *gc-quiet* (format t "~&;; GC.. ")) @@ -399,23 +399,26 @@ "If x is in oldspace, migrate it to newspace." (declare (ignore location)) (cond + ((null x) + nil) ((not (object-in-space-p oldspace x)) x) - (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) - (object-tag x))) - forwarded-x) - (let ((forward-x (shallow-copy x))) - (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)))) - (setf (memref (object-location x) 0 0 :lisp) forward-x) - forward-x))))))))) + (t + (or (and (eq (object-tag x) + (ldb (byte 3 0) + (memref (object-location x) 0 0 :unsigned-byte8))) + (let ((forwarded-x (memref (object-location x) 0 0 :lisp))) + (and (object-in-space-p newspace forwarded-x) + forwarded-x))) + (let ((forward-x (shallow-copy x))) + (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)))) + (setf (memref (object-location x) 0 0 :lisp) forward-x) + forward-x)))))))) (setf *gc-stack* (muerte::copy-control-stack)) ;; Scavenge roots (dolist (range muerte::%memory-map-roots%)