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%)