- (multiple-value-bind (start end) (space-bounds space)
- (declare (type system-area-pointer start end))
- (declare (optimize (speed 3)))
- (let ((current start)
- #!+gencgc (skip-tests-until-addr 0))
- (labels ((maybe-finish-mapping ()
- (unless (sap< current end)
- (aver (sap= current end))
- (return-from map-allocated-objects)))
- ;; GENCGC doesn't allocate linearly, which means that the
- ;; dynamic space can contain large blocks zeros that get
- ;; accounted as conses in ROOM (and slow down other
- ;; applications of MAP-ALLOCATED-OBJECTS). To fix this
- ;; check the GC page structure for the current address.
- ;; If the page is free or the address is beyond the page-
- ;; internal allocation offset (bytes-used) skip to the
- ;; next page immediately.
- (maybe-skip-page ()
- #!+gencgc
- (when (eq space :dynamic)
- (loop with page-mask = #.(1- sb!vm:gencgc-page-size)
- for addr of-type sb!vm:word = (sap-int current)
- while (>= addr skip-tests-until-addr)
- do
- ;; For some reason binding PAGE with LET
- ;; conses like mad (but gives no compiler notes...)
- ;; Work around the problem with SYMBOL-MACROLET
- ;; instead of trying to figure out the real
- ;; issue. -- JES, 2005-05-17
- (symbol-macrolet
- ((page (deref page-table
- (find-page-index addr))))
- ;; Don't we have any nicer way to access C struct
- ;; bitfields?
- (let ((alloc-flag (ldb (byte 3 2)
- (slot page 'flags)))
- (bytes-used (slot page 'bytes-used)))
- ;; If the page is not free and the current
- ;; pointer is still below the allocation offset
- ;; of the page
- (when (and (not (zerop alloc-flag))
- (<= (logand page-mask addr)
- bytes-used))
- ;; Don't bother testing again until we
- ;; get past that allocation offset
- (setf skip-tests-until-addr
- (+ (logandc2 addr page-mask)
- (the fixnum bytes-used)))
- ;; And then continue with the scheduled
- ;; mapping
- (return-from maybe-skip-page))
- ;; Move CURRENT to start of next page
- (setf current (int-sap (+ (logandc2 addr page-mask)
- sb!vm:gencgc-page-size)))
- (maybe-finish-mapping)))))))
- (declare (inline maybe-finish-mapping maybe-skip-page))
- (loop
- (maybe-finish-mapping)
- (maybe-skip-page)
- (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)))
- (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)))
- (setq current (sap+ current size))))))))))))
-
+ (ecase space
+ (:static
+ ;; Static space starts with NIL, which requires special
+ ;; handling, as the header and alignment are slightly off.
+ (multiple-value-bind (start end) (space-bounds space)
+ (funcall fun nil symbol-header-widetag (* 8 n-word-bytes))
+ (map-objects-in-range fun
+ (%make-lisp-obj (+ (* 8 n-word-bytes)
+ (sap-int start)))
+ (%make-lisp-obj (sap-int end)))))
+
+ ((:read-only #!-gencgc :dynamic)
+ ;; Read-only space (and dynamic space on cheneygc) is a block
+ ;; of contiguous allocations.
+ (multiple-value-bind (start end) (space-bounds space)
+ (map-objects-in-range fun
+ (%make-lisp-obj (sap-int start))
+ (%make-lisp-obj (sap-int end)))))
+
+ #!+gencgc
+ (:dynamic
+ ;; Dynamic space on gencgc requires walking the GC page tables
+ ;; in order to determine what regions contain objects.
+
+ ;; We explicitly presume that any pages in an allocation region
+ ;; that are in-use have a BYTES-USED of GENCGC-CARD-BYTES
+ ;; (indicating a full page) or an otherwise-valid BYTES-USED.
+ ;; We also presume that the pages of an open allocation region
+ ;; after the first page, and any pages that are unallocated,
+ ;; have a BYTES-USED of zero. GENCGC seems to guarantee this.
+
+ ;; Our procedure is to scan forward through the page table,
+ ;; maintaining an "end pointer" until we reach a page where
+ ;; BYTES-USED is not GENCGC-CARD-BYTES or we reach
+ ;; LAST-FREE-PAGE. We then MAP-OBJECTS-IN-RANGE if the range
+ ;; is not empty, and proceed to the next page (unless we've hit
+ ;; LAST-FREE-PAGE). We happily take advantage of the fact that
+ ;; MAP-OBJECTS-IN-RANGE will simply return if passed two
+ ;; coincident pointers for the range.
+
+ ;; FIXME: WITHOUT-GCING prevents a GC flip, but doesn't prevent
+ ;; closing allocation regions and opening new ones. This may
+ ;; prove to be an issue with concurrent systems, or with
+ ;; spectacularly poor timing for closing an allocation region
+ ;; in a single-threaded system.
+
+ (loop
+ with page-size = (ash gencgc-card-bytes (- n-fixnum-tag-bits))
+ ;; This magic dance gets us an unboxed aligned pointer as a
+ ;; FIXNUM.
+ with start = (sap-ref-lispobj (alien-sap (addr heap-base)) 0)
+ with end = start
+
+ ;; This is our page range.
+ for page-index from 0 below last-free-page
+ for next-page-addr from (+ start page-size) by page-size
+ for page-bytes-used = (slot (deref page-table page-index) 'bytes-used)
+
+ when (< page-bytes-used gencgc-card-bytes)
+ do (progn
+ (incf end (ash page-bytes-used (- n-fixnum-tag-bits)))
+ (map-objects-in-range fun start end)
+ (setf start next-page-addr)
+ (setf end next-page-addr))
+ else do (incf end page-size)
+
+ finally (map-objects-in-range fun start end))))))
projects / sbcl.git / blobdiff