From 5fcd7e43ee6459540167de960e7e74d0403a211c Mon Sep 17 00:00:00 2001 From: rtoy <rtoy> Date: Fri, 18 Jun 2004 17:44:28 +0000 Subject: [PATCH] Less consy ROOM function. Also fixes an issue where ROOM appeared to cause garbage to be retained with gencgc on x86 (but not sparc), eventually causing an out-of-heap error. From Helmut Eller, via cmucl-imp. --- code/room.lisp | 26 ++++++++++++++------------ 1 file changed, 14 insertions(+), 12 deletions(-) diff --git a/code/room.lisp b/code/room.lisp index 984a51bbc..d85417db2 100644 --- a/code/room.lisp +++ b/code/room.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/room.lisp,v 1.32 2004/04/13 13:21:52 rtoy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/room.lisp,v 1.33 2004/06/18 17:44:28 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -187,10 +187,15 @@ (space-bounds space) (declare (type system-area-pointer start end)) (declare (optimize (speed 3) (safety 0))) - (let ((current start) - #+nil - (prev nil)) - (loop + (iterate step ((current start)) + (flet ((next (size) + (let ((c (etypecase size + (fixnum (sap+ current size)) + (memory-size (sap+ current size))))) + (cond ((sap< c end) + (step c)) + (t + (assert (sap= c end))))))) (let* ((header (sap-ref-32 current 0)) (header-type (logand header #xFF)) (info (svref *room-info* header-type))) @@ -203,7 +208,7 @@ list-pointer-type)) list-pointer-type size) - (setq current (sap+ current size)))) + (next size))) ((eql header-type closure-header-type) (let* ((obj (make-lisp-obj (logior (sap-int current) function-pointer-type))) @@ -211,7 +216,7 @@ (* (the fixnum (1+ (get-closure-length obj))) word-bytes)))) (funcall fun obj header-type size) - (setq current (sap+ current size)))) + (next size))) ((eq (room-info-kind info) :instance) (let* ((obj (make-lisp-obj (logior (sap-int current) instance-pointer-type))) @@ -224,7 +229,7 @@ (when (> size 200000) (break "Implausible size, prev ~S" prev)) #+nil (setq prev current) - (setq current (sap+ current size)))) + (next size))) (t (let* ((obj (make-lisp-obj (logior (sap-int current) other-pointer-type))) @@ -254,10 +259,7 @@ (break "Implausible size, prev ~S" prev)) #+nil (setq prev current) - (setq current (sap+ current size)))))) - (unless (sap< current end) - (assert (sap= current end)) - (return))) + (next size)))))) #+nil prev)))) -- GitLab