+ (logand (the word (+ size lowtag-mask)) (lognot lowtag-mask)))
+
+;;; Return the vector OBJ, its WIDETAG, and the number of octets
+;;; required for its storage (including padding and alignment).
+(defun reconstitute-vector (obj saetp)
+ (declare (type (simple-array * (*)) obj)
+ (type specialized-array-element-type-properties saetp))
+ (let* ((length (+ (length obj)
+ (saetp-n-pad-elements saetp)))
+ (n-bits (saetp-n-bits saetp))
+ (alignment-pad (floor 7 n-bits))
+ (n-data-octets (if (>= n-bits 8)
+ (* length (ash n-bits -3))
+ (ash (* (+ length alignment-pad)
+ n-bits)
+ -3))))
+ (values obj
+ (saetp-typecode saetp)
+ (round-to-dualword (+ (* vector-data-offset n-word-bytes)
+ n-data-octets)))))
+
+;;; Given the address (untagged, aligned, and interpreted as a FIXNUM)
+;;; of a lisp object, return the object, its "type code" (either
+;;; LIST-POINTER-LOWTAG or a header widetag), and the number of octets
+;;; required for its storage (including padding and alignment). Note
+;;; that this function is designed to NOT CONS, even if called
+;;; out-of-line.
+(defun reconstitute-object (address)
+ (let* ((object-sap (int-sap (get-lisp-obj-address address)))
+ (header (sap-ref-word object-sap 0))
+ (widetag (logand header widetag-mask))
+ (header-value (ash header (- n-widetag-bits)))
+ (info (svref *room-info* widetag)))
+ (symbol-macrolet
+ ((boxed-size (round-to-dualword (ash (1+ header-value) word-shift))))
+ (macrolet
+ ((tagged-object (tag)
+ `(%make-lisp-obj (logior ,tag (get-lisp-obj-address address)))))
+ (cond
+ ;; Pick off arrays, as they're the only plausible cause for
+ ;; a non-nil, non-ROOM-INFO object as INFO.
+ ((specialized-array-element-type-properties-p info)
+ (reconstitute-vector (tagged-object other-pointer-lowtag) info))
+
+ ((null info)
+ (error "Unrecognized widetag #x~2,'0X in reconstitute-object"
+ widetag))
+
+ ((eq (room-info-kind info) :list)
+ (values (tagged-object list-pointer-lowtag)
+ list-pointer-lowtag
+ (* 2 n-word-bytes)))
+
+ ((eq (room-info-kind info) :closure)
+ (values (tagged-object fun-pointer-lowtag)
+ widetag
+ boxed-size))
+
+ ((eq (room-info-kind info) :instance)
+ (values (tagged-object instance-pointer-lowtag)
+ widetag
+ boxed-size))
+
+ ((eq (room-info-kind info) :other)
+ (values (tagged-object other-pointer-lowtag)
+ widetag
+ boxed-size))
+
+ ((eq (room-info-kind info) :vector-nil)
+ (values (tagged-object other-pointer-lowtag)
+ simple-array-nil-widetag
+ (* 2 n-word-bytes)))
+
+ ((eq (room-info-kind info) :weak-pointer)
+ (values (tagged-object other-pointer-lowtag)
+ weak-pointer-widetag
+ (round-to-dualword
+ (* weak-pointer-size
+ n-word-bytes))))
+
+ ((eq (room-info-kind info) :code)
+ (values (tagged-object other-pointer-lowtag)
+ code-header-widetag
+ (round-to-dualword
+ (* (+ header-value
+ (the fixnum
+ (sap-ref-lispobj object-sap
+ (* code-code-size-slot
+ n-word-bytes))))
+ n-word-bytes))))
+
+ (t
+ (error "Unrecognized room-info-kind ~S in reconstitute-object"
+ (room-info-kind info))))))))
+
+;;; Iterate over all the objects in the contiguous block of memory
+;;; with the low address at START and the high address just before
+;;; END, calling FUN with the object, the object's type code, and the
+;;; object's total size in bytes, including any header and padding.
+;;; START and END are untagged, aligned memory addresses interpreted
+;;; as FIXNUMs (unlike SAPs or tagged addresses, these will not cons).
+(defun map-objects-in-range (fun start end)
+ (declare (type function fun))
+ ;; If START is (unsigned) greater than END, then we have somehow
+ ;; blown past our endpoint.
+ (aver (<= (get-lisp-obj-address start)
+ (get-lisp-obj-address end)))
+ (unless (= start end)
+ (multiple-value-bind
+ (obj typecode size)
+ (reconstitute-object start)
+ (aver (zerop (logand n-lowtag-bits size)))
+ (let ((next-start
+ ;; This special little dance is to add a number of octets
+ ;; (and it had best be a number evenly divisible by our
+ ;; allocation granularity) to an unboxed, aligned address
+ ;; masquerading as a fixnum. Without consing.
+ (%make-lisp-obj
+ (mask-field (byte #.n-word-bits 0)
+ (+ (get-lisp-obj-address start)
+ size)))))
+ (funcall fun obj typecode size)
+ (map-objects-in-range fun next-start end)))))
+
+;;; Access to the GENCGC page table for better precision in
+;;; MAP-ALLOCATED-OBJECTS
+#!+gencgc
+(progn
+ (define-alien-type (struct page)
+ (struct page
+ (start signed)
+ ;; On platforms with small enough GC pages, this field
+ ;; will be a short. On platforms with larger ones, it'll
+ ;; be an int.
+ (bytes-used (unsigned
+ #.(if (typep sb!vm:gencgc-card-bytes
+ '(unsigned-byte 16))
+ 16
+ 32)))
+ (flags (unsigned 8))
+ (gen (signed 8))))
+ (declaim (inline find-page-index))
+ (define-alien-routine "find_page_index" long (index signed))
+ (define-alien-variable "last_free_page" sb!kernel::page-index-t)
+ (define-alien-variable "heap_base" (* t))
+ (define-alien-variable "page_table" (* (struct page))))