From: Juho Snellman Date: Wed, 14 Dec 2005 03:39:23 +0000 (+0000) Subject: 0.9.7.28: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=70769503c505c22bddef3bc7885b91b9d503607f;p=sbcl.git 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 --- 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 --- 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 --- 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)))))))))))) + ;;;; MEMORY-USAGE diff --git a/src/compiler/x86-64/parms.lisp b/src/compiler/x86-64/parms.lisp index 1c8d06e..06f0420 100644 --- 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 --- 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 --- 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 #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 --- 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"