0.9.7.28:

        Make MAP-ALLOCATED-OBJECTS use gencgc pagetable information to
        skip over free dynamic space regions.

        * More accurate ROOM results (previously all empty space up to
          the fake allocation pointer would get counted as conses)
        * Usually faster
        * Needed for some GC work that might get committed in the future
        * Genesify the GENCGC page size, while since it's now needed
          in Lisp

diff --git a/NEWS b/NEWS
index 38a9669..393e251 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -19,6 +19,7 @@ changes in sbcl-0.9.8 relative to sbcl-0.9.7:
   * optimization: improved type inference for arithmetic-for
     index variables in LOOP
   * optimization: faster floating-point SQRT on x86-64
+  * bug fix: more accurate ROOM results on GENCGC platforms
   * fixed some bugs revealed by Paul Dietz' test suite:
     ** DOCUMENTATION returns NIL instead of "" for method combinations
        that don't have a docstring

diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr
index 9f66124..e0a5612 100644 (file)
--- a/package-data-list.lisp-expr
+++ b/package-data-list.lisp-expr
@@ -2158,6 +2158,7 @@ structure representations"
                "SIMPLE-FUN-TYPE-SLOT"
                "FUNCALLABLE-INSTANCE-LAYOUT-SLOT"
                "FUNCALLABLE-INSTANCE-LEXENV-SLOT"
+               "GENCGC-PAGE-SIZE"
                "GENESIS" "HALT-TRAP" "IGNORE-ME-SC-NUMBER"
                "IMMEDIATE-CHARACTER-SC-NUMBER" "IMMEDIATE-SAP-SC-NUMBER"
                "IMMEDIATE-SC-NUMBER" "*INITIAL-DYNAMIC-SPACE-FREE-POINTER*"

diff --git a/src/code/room.lisp b/src/code/room.lisp
index 6033ac0..c957c8d 100644 (file)
--- a/src/code/room.lisp
+++ b/src/code/room.lisp
@@ -204,6 +204,24 @@
                       shift)
                  (ash len shift)))))))
 
+;;; Access to the GENCGC page table for better precision in
+;;; MAP-ALLOCATED-OBJECTS
+#!+gencgc
+(progn
+  (define-alien-type nil
+      (struct page
+              (flags unsigned-int)
+              (gen int)
+              (bytes-used int)
+              (start long)))
+  (declaim (inline find-page-index))
+  (define-alien-routine "find_page_index" long (index long))
+  (define-alien-variable "page_table"
+      (array (struct page)
+             #.(truncate (- dynamic-space-end
+                            dynamic-space-start)
+                         sb!vm:gencgc-page-size))))
+
 ;;; Iterate over all the objects allocated in SPACE, calling FUN with
 ;;; the object, the object's type code, and the object's total size in
 ;;; bytes, including any header and padding.
@@ -211,84 +229,122 @@
 (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)))
-      (let ((current start)
-            #+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)
+   (multiple-value-bind (start end) (space-bounds space)
+     (declare (type system-area-pointer start end))
+     (declare (optimize (speed 3) (safety 0)))
+     (let ((current start)
+           (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)))
-                #+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))))
+                                          (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))))))))))))
+
 \f
 ;;;; MEMORY-USAGE
 

diff --git a/src/compiler/x86-64/parms.lisp b/src/compiler/x86-64/parms.lisp
index 1c8d06e..06f0420 100644 (file)
--- a/src/compiler/x86-64/parms.lisp
+++ b/src/compiler/x86-64/parms.lisp
@@ -35,6 +35,10 @@
 ;;; addressable object
 (def!constant n-byte-bits 8)
 
+;;; The size in bytes of the GENCGC pages. Should be a multiple of the
+;;; architecture code size.
+(def!constant gencgc-page-size 4096)
+
 (def!constant float-sign-shift 31)
 
 ;;; comment from CMU CL:

diff --git a/src/compiler/x86/parms.lisp b/src/compiler/x86/parms.lisp
index e6dc71d..c6edb03 100644 (file)
--- a/src/compiler/x86/parms.lisp
+++ b/src/compiler/x86/parms.lisp
@@ -35,6 +35,10 @@
 ;;; addressable object
 (def!constant n-byte-bits 8)
 
+;;; The size in bytes of the GENCGC pages. Should be a multiple of the
+;;; architecture code size.
+(def!constant gencgc-page-size 4096)
+
 (def!constant float-sign-shift 31)
 
 ;;; comment from CMU CL:

diff --git a/src/runtime/gencgc-internal.h b/src/runtime/gencgc-internal.h
index 41642ec..c7fb5c5 100644 (file)
--- a/src/runtime/gencgc-internal.h
+++ b/src/runtime/gencgc-internal.h
@@ -19,14 +19,12 @@
 #ifndef _GENCGC_INTERNAL_H_
 #define _GENCGC_INTERNAL_H_
 
+#include <limits.h>
 #include "gc.h"
 #include "gencgc-alloc-region.h"
 #include "genesis/code.h"
 
-/* Size of a page, in bytes. FIXME: needs to be conditionalized per
- * architecture, preferably by someone with a clue as to what page
- * sizes are on archs other than x86 and PPC - Patrik */
-#define PAGE_BYTES 4096
+#define PAGE_BYTES GENCGC_PAGE_SIZE
 
 void gc_free_heap(void);
 inline page_index_t find_page_index(void *);

diff --git a/version.lisp-expr b/version.lisp-expr
index eeac556..306f54a 100644 (file)
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.9.7.27"
+"0.9.7.28"