Raymond Toy <[EMAIL PROTECTED]> writes:
> ROOM conses a lot. That might cause the problems too. Using (room
> nil) instead of (room) allows your test to finish, so (room) must be
> causing things to survive that shouldn't.
Some time ago the type of the "size" argument for
map-allocated-objects was changed from fixnum to (unsigned-byte 32)
and it seems that the compiler uses an unfortunate representation for
the "current" pointer when stepping through the heap (indicated by the
"Doing SAP to pointer coercion" notes).
May I propose to change map-allocated-objects a little. The variant
below conses a lot less, at least on my x86. Perhaps sap+ could be
made smarter to avoid this kind of consing?
(defun map-allocated-objects (fun space)
(declare (type function fun) (type spaces space))
(without-gcing
(multiple-value-bind (start end)
(space-bounds space)
(declare (type system-area-pointer start end))
(declare (optimize (speed 3) (safety 0)))
(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)))
(cond
((or (not info)
(eq (room-info-kind info) :lowtag))
(let ((size (* cons-size word-bytes)))
(funcall fun
(make-lisp-obj (logior (sap-int current)
list-pointer-type))
list-pointer-type
size)
(next size)))
((eql header-type closure-header-type)
(let* ((obj (make-lisp-obj (logior (sap-int current)
function-pointer-type)))
(size (round-to-dualword
(* (the fixnum (1+ (get-closure-length obj)))
word-bytes))))
(funcall fun obj header-type size)
(next size)))
((eq (room-info-kind info) :instance)
(let* ((obj (make-lisp-obj
(logior (sap-int current) instance-pointer-type)))
(size (round-to-dualword
(* (+ (%instance-length obj) 1) word-bytes))))
(declare (type memory-size size))
(funcall fun obj header-type size)
(assert (zerop (logand size lowtag-mask)))
#+nil
(when (> size 200000) (break "Implausible size, prev ~S" prev))
#+nil
(setq prev current)
(next size)))
(t
(let* ((obj (make-lisp-obj
(logior (sap-int current) other-pointer-type)))
(size (ecase (room-info-kind info)
(:fixed
(assert (or (eql (room-info-length info)
(1+ (get-header-data obj)))
(floatp obj)))
(round-to-dualword
(* (room-info-length info) word-bytes)))
((:vector :string)
(vector-total-size obj info))
(:header
(round-to-dualword
(* (1+ (get-header-data obj)) word-bytes)))
(:code
(+ (the fixnum
(* (get-header-data obj) word-bytes))
(round-to-dualword
(* (the fixnum (%code-code-size obj))
word-bytes)))))))
(declare (type memory-size size))
(funcall fun obj header-type size)
(assert (zerop (logand size lowtag-mask)))
#+nil
(when (> size 200000)
(break "Implausible size, prev ~S" prev))
#+nil
(setq prev current)
(next size))))))
#+nil
prev))))
