- #+nil
- (prev nil))
- (loop
- (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)
- (setq current (sap+ current 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)
- (setq current (sap+ current 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 (fixnum size))
- (funcall fun obj header-type size)
- (aver (zerop (logand size lowtag-mask)))
- #+nil
- (when (> size 200000) (break "implausible size, prev ~S" prev))
- #+nil
- (setq prev current)
- (setq current (sap+ current size))))
- (t
- (let* ((obj (make-lisp-obj
- (logior (sap-int current) other-pointer-type)))
- (size (ecase (room-info-kind info)
- (:fixed
- (aver (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 (fixnum size))
- (funcall fun obj header-type size)
- (aver (zerop (logand size lowtag-mask)))
- #+nil
- (when (> size 200000)
- (break "Implausible size, prev ~S" prev))
- #+nil
- (setq prev current)
- (setq current (sap+ current size))))))
- (unless (sap< current end)
- (aver (sap= current end))
- (return)))
-
- #+nil
- prev))))
+ #+nil
+ (prev nil))
+ (loop
+ (let* ((header (sap-ref-word current 0))
+ (header-widetag (logand header #xFF))
+ (info (svref *room-info* header-widetag)))
+ (cond
+ ((or (not info)
+ (eq (room-info-kind info) :lowtag))
+ (let ((size (* cons-size n-word-bytes)))
+ (funcall fun
+ (make-lisp-obj (logior (sap-int current)
+ list-pointer-lowtag))
+ list-pointer-lowtag
+ size)
+ (setq current (sap+ current size))))
+ ((eql header-widetag closure-header-widetag)
+ (let* ((obj (make-lisp-obj (logior (sap-int current)
+ fun-pointer-lowtag)))
+ (size (round-to-dualword
+ (* (the fixnum (1+ (get-closure-length obj)))
+ n-word-bytes))))
+ (funcall fun obj header-widetag size)
+ (setq current (sap+ current size))))
+ ((eq (room-info-kind info) :instance)
+ (let* ((obj (make-lisp-obj
+ (logior (sap-int current) instance-pointer-lowtag)))
+ (size (round-to-dualword
+ (* (+ (%instance-length obj) 1) n-word-bytes))))
+ (declare (fixnum size))
+ (funcall fun obj header-widetag size)
+ (aver (zerop (logand size lowtag-mask)))
+ #+nil
+ (when (> size 200000) (break "implausible size, prev ~S" prev))
+ #+nil
+ (setq prev current)
+ (setq current (sap+ current size))))
+ (t
+ (let* ((obj (make-lisp-obj
+ (logior (sap-int current) other-pointer-lowtag)))
+ (size (ecase (room-info-kind info)
+ (:fixed
+ (aver (or (eql (room-info-length info)
+ (1+ (get-header-data obj)))
+ (floatp obj)
+ (simple-array-nil-p obj)))
+ (round-to-dualword
+ (* (room-info-length info) n-word-bytes)))
+ ((:vector :string)
+ (vector-total-size obj info))
+ (:header
+ (round-to-dualword
+ (* (1+ (get-header-data obj)) n-word-bytes)))
+ (:code
+ (+ (the fixnum
+ (* (get-header-data obj) n-word-bytes))
+ (round-to-dualword
+ (* (the fixnum (%code-code-size obj))
+ n-word-bytes)))))))
+ (declare (fixnum size))
+ (funcall fun obj header-widetag size)
+ (aver (zerop (logand size lowtag-mask)))
+ #+nil
+ (when (> size 200000)
+ (break "Implausible size, prev ~S" prev))
+ #+nil
+ (setq prev current)
+ (setq current (sap+ current size))))))
+ (unless (sap< current end)
+ (aver (sap= current end))
+ (return)))
+
+ #+nil
+ prev))))