From afbae954761ff3771859d23294b72310c296d9e7 Mon Sep 17 00:00:00 2001 From: Douglas Katzman Date: Sat, 22 Nov 2014 17:29:15 -0500 Subject: [PATCH] x86-64: Integrate Paul Khuong's interleaved raw slot feature. with significant amounts of conditionalization and the new implementation of EQUALP and other fixes by me. --- NEWS | 3 + contrib/sb-introspect/introspect.lisp | 12 +- make-config.sh | 1 + package-data-list.lisp-expr | 11 +- src/code/class.lisp | 55 +++++---- src/code/condition.lisp | 2 +- src/code/defbangstruct.lisp | 4 +- src/code/defstruct.lisp | 66 +++++++---- src/code/early-raw-slots.lisp | 132 ++++++++++++++++++++++ src/code/fop.lisp | 35 ++++-- src/code/pred.lisp | 47 +++++--- src/code/room.lisp | 3 +- src/code/sharpm.lisp | 16 +-- src/code/target-defstruct.lisp | 98 ++++++++++++---- src/code/target-sxhash.lisp | 26 +++-- src/compiler/dump.lisp | 12 +- src/compiler/fopcompile.lisp | 4 +- src/compiler/generic/genesis.lisp | 92 ++++++++++----- src/compiler/generic/vm-ir2tran.lisp | 5 +- src/compiler/ir1tran.lisp | 11 ++ src/compiler/x86-64/cell.lisp | 192 ++++++++------------------------ src/runtime/gc-common.c | 80 ++++++++++++- src/runtime/gc-internal.h | 8 ++ src/runtime/gencgc.c | 8 +- tests/defstruct.impure.lisp | 49 +++++++- tests/raw-slots-interleaved.impure.lisp | 137 +++++++++++++++++++++++ 26 files changed, 803 insertions(+), 306 deletions(-) create mode 100644 tests/raw-slots-interleaved.impure.lisp diff --git a/NEWS b/NEWS index 730d7bb7c..0c788aa08 100644 --- a/NEWS +++ b/NEWS @@ -3,6 +3,9 @@ changes relative to sbcl-1.2.5: * enhancement: SERVE-EVENTS uses the poll() system call in lieu of select() if the OS has the former. Previously poll() was used only if waiting on exactly one file descriptor. + * enhancement: efficiency of access to untagged structure slots is improved + on x86-64, and the order of slots in memory is exactly as specified by + defstruct, simplifying use of structures as arguments to foreign calls. * bug fix: SB-DEBUG:ARG now works in all TRACE options which evaluate forms. (lp#1357826) * bug fix: GC memory corruption during internal memory handling. diff --git a/contrib/sb-introspect/introspect.lisp b/contrib/sb-introspect/introspect.lisp index d6c0190ae..f17078f28 100644 --- a/contrib/sb-introspect/introspect.lisp +++ b/contrib/sb-introspect/introspect.lisp @@ -907,13 +907,11 @@ Experimental: interface subject to change." (call (realpart object)) (call (realpart object))) (sb-vm::instance - (let* ((len (sb-kernel:%instance-length object)) - (nuntagged (if (typep object 'structure-object) - (sb-kernel:layout-n-untagged-slots - (sb-kernel:%instance-layout object)) - 0))) - (dotimes (i (- len nuntagged)) - (call (sb-kernel:%instance-ref object i)))) + (if (typep object 'structure-object) + (sb-kernel:do-instance-tagged-slot (i object) + (call (sb-kernel:%instance-ref object i))) + (dotimes (i (sb-kernel:%instance-length object)) + (call (sb-kernel:%instance-ref object i)))) #+sb-thread (when (typep object 'sb-thread:thread) (cond ((eq object sb-thread:*current-thread*) diff --git a/make-config.sh b/make-config.sh index 224b4f919..326743692 100755 --- a/make-config.sh +++ b/make-config.sh @@ -637,6 +637,7 @@ if [ "$sbcl_arch" = "x86" ]; then elif [ "$sbcl_arch" = "x86-64" ]; then printf ' :gencgc :stack-grows-downward-not-upward :c-stack-is-control-stack :linkage-table' >> $ltf printf ' :compare-and-swap-vops :unwind-to-frame-and-call-vop :raw-instance-init-vops' >> $ltf + printf ' :interleaved-raw-slots' >> $ltf printf ' :stack-allocatable-closures :stack-allocatable-vectors' >> $ltf printf ' :stack-allocatable-lists :stack-allocatable-fixed-objects' >> $ltf printf ' :alien-callbacks :cycle-counter :complex-float-vops' >> $ltf diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 3c43b6838..376ebdacf 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -1561,6 +1561,7 @@ is a good idea, but see SB-SYS re. blurring of boundaries." "!DEFSTRUCT-WITH-ALTERNATE-METACLASS" "DESCEND-INTO" "DIVISION-BY-ZERO-ERROR" "DO-REST-ARG" + "DO-INSTANCE-TAGGED-SLOT" "DOUBLE-FLOAT-EXPONENT" "DOUBLE-FLOAT-HIGH-BITS" "DOUBLE-FLOAT-INT-EXPONENT" "DOUBLE-FLOAT-LOW-BITS" "DOUBLE-FLOAT-SIGNIFICAND" @@ -1607,8 +1608,14 @@ is a good idea, but see SB-SYS re. blurring of boundaries." "INVALID-UNWIND-ERROR" "IRRATIONAL" "JUST-DUMP-IT-NORMALLY" "KEY-INFO" "KEY-INFO-NAME" "KEY-INFO-P" "KEY-INFO-TYPE" - "LAYOUT-DEPTHOID" "LAYOUT-INVALID-ERROR" - "LAYOUT-N-UNTAGGED-SLOTS" "LAYOUT-FOR-STD-CLASS-P" + "LAYOUT-DEPTHOID" "LAYOUT-EQUALP-TESTS" "LAYOUT-INVALID-ERROR" + ;; -METADATA is the wrapper over one or the other of the two + ;; 'untagged' accessors, not both of which are present. + ;; There's not need to featurize out, because Genesis will dtrt + ;; and dump only the present symbols. + "LAYOUT-RAW-SLOT-METADATA" + "LAYOUT-N-UNTAGGED-SLOTS" "LAYOUT-UNTAGGED-BITMAP" + "LAYOUT-FOR-STD-CLASS-P" "LAYOUT-SLOT-LIST" "LAYOUT-SLOT-TABLE" #!+(or x86-64 x86) "%LEA" "LEXENV" "LEXENV-DESIGNATOR" "LINE-LENGTH" diff --git a/src/code/class.lisp b/src/code/class.lisp index 7fc460e5d..fb15e9ece 100644 --- a/src/code/class.lisp +++ b/src/code/class.lisp @@ -194,7 +194,10 @@ ;; This slot is known to the C runtime support code. ;; It counts the number of untagged cells, not user-visible slots. ;; e.g. on 32-bit machines, each (COMPLEX DOUBLE-FLOAT) counts as 4. - (n-untagged-slots 0 :type index) + #!-interleaved-raw-slots (n-untagged-slots 0 :type index) + ;; Metadata + #!+interleaved-raw-slots (untagged-bitmap 0 :type unsigned-byte) + #!+interleaved-raw-slots (equalp-tests #() :type simple-vector) ;; Definition location (source-location nil) ;; If this layout is for an object of metatype STANDARD-CLASS, @@ -288,18 +291,18 @@ ;;; its class slot value is set to an UNDEFINED-CLASS. -- FIXME: This ;;; is no longer true, :UNINITIALIZED used instead. (declaim (ftype (function (layout classoid index simple-vector layout-depthoid - index) + layout-raw-slot-metadata-type) layout) %init-or-check-layout)) (defun %init-or-check-layout - (layout classoid length inherits depthoid nuntagged) + (layout classoid length inherits depthoid raw-slot-metadata) (cond ((eq (layout-invalid layout) :uninitialized) ;; There was no layout before, we just created one which ;; we'll now initialize with our information. (setf (layout-length layout) length (layout-inherits layout) inherits (layout-depthoid layout) depthoid - (layout-n-untagged-slots layout) nuntagged + (layout-raw-slot-metadata layout) raw-slot-metadata (layout-classoid layout) classoid (layout-invalid layout) nil)) ;; FIXME: Now that LAYOUTs are born :UNINITIALIZED, maybe this @@ -311,10 +314,11 @@ ;; information, and we'll now check that old information ;; which was known with certainty is consistent with current ;; information which is known with certainty. - (check-layout layout classoid length inherits depthoid nuntagged))) + (check-layout layout classoid length inherits depthoid + raw-slot-metadata))) layout) -;;; In code for the target Lisp, we don't use dump LAYOUTs using the +;;; In code for the target Lisp, we don't dump LAYOUTs using the ;;; standard load form mechanism, we use special fops instead, in ;;; order to make cold load come out right. But when we're building ;;; the cross-compiler, we can't do that because we don't have access @@ -351,7 +355,7 @@ ',(layout-length layout) ',(layout-inherits layout) ',(layout-depthoid layout) - ',(layout-n-untagged-slots layout))))) + ',(layout-raw-slot-metadata layout))))) ;;; If LAYOUT's slot values differ from the specified slot values in ;;; any interesting way, then give a warning and return T. @@ -361,10 +365,11 @@ index simple-vector layout-depthoid - index)) + layout-raw-slot-metadata-type)) redefine-layout-warning)) (defun redefine-layout-warning (old-context old-layout - context length inherits depthoid nuntagged) + context length inherits depthoid + raw-slot-metadata) (declare (type layout old-layout) (type simple-string old-context context)) (let ((name (layout-proper-name old-layout))) (or (let ((old-inherits (layout-inherits old-layout))) @@ -400,14 +405,19 @@ old-context old-length context length) t)) - (let ((old-nuntagged (layout-n-untagged-slots old-layout))) - (unless (= old-nuntagged nuntagged) + (let ((old-metadata (layout-raw-slot-metadata old-layout))) + (unless (= old-metadata raw-slot-metadata) + #!-interleaved-raw-slots (warn "change in instance layout of class ~S:~% ~ ~A untagged slots: ~W~% ~ ~A untagged slots: ~W" name - old-context old-nuntagged - context nuntagged) + old-context old-metadata + context raw-slot-metadata) + #!+interleaved-raw-slots + (warn "change in placement of raw slots of class ~S ~ +between the ~A definition and the ~A definition" + name old-context context) t)) (unless (= (layout-depthoid old-layout) depthoid) (warn "change in the inheritance structure of class ~S~% ~ @@ -418,13 +428,14 @@ ;;; Require that LAYOUT data be consistent with CLASS, LENGTH, ;;; INHERITS, and DEPTHOID. (declaim (ftype (function - (layout classoid index simple-vector layout-depthoid index)) + (layout classoid index simple-vector layout-depthoid + layout-raw-slot-metadata-type)) check-layout)) -(defun check-layout (layout classoid length inherits depthoid nuntagged) +(defun check-layout (layout classoid length inherits depthoid raw-slot-metadata) (aver (eq (layout-classoid layout) classoid)) (when (redefine-layout-warning "current" layout "compile time" length inherits depthoid - nuntagged) + raw-slot-metadata) ;; Classic CMU CL had more options here. There are several reasons ;; why they might want more options which are less appropriate for ;; us: (1) It's hard to fit the classic CMU CL flexible approach @@ -448,10 +459,11 @@ ;;; Used by the loader to forward-reference layouts for classes whose ;;; definitions may not have been loaded yet. This allows type tests ;;; to be loaded when the type definition hasn't been loaded yet. -(declaim (ftype (function (symbol index simple-vector layout-depthoid index) +(declaim (ftype (function (symbol index simple-vector layout-depthoid + layout-raw-slot-metadata-type) layout) find-and-init-or-check-layout)) -(defun find-and-init-or-check-layout (name length inherits depthoid nuntagged) +(defun find-and-init-or-check-layout (name length inherits depthoid metadata) (with-world-lock () (let ((layout (find-layout name))) (%init-or-check-layout layout @@ -460,7 +472,7 @@ length inherits depthoid - nuntagged)))) + metadata)))) ;;; Record LAYOUT as the layout for its class, adding it as a subtype ;;; of all superclasses. This is the operation that "installs" a @@ -505,9 +517,10 @@ (if destruct-layout (setf (layout-invalid destruct-layout) nil (layout-inherits destruct-layout) (layout-inherits layout) - (layout-depthoid destruct-layout)(layout-depthoid layout) + (layout-depthoid destruct-layout) (layout-depthoid layout) (layout-length destruct-layout) (layout-length layout) - (layout-n-untagged-slots destruct-layout) (layout-n-untagged-slots layout) + (layout-raw-slot-metadata destruct-layout) + (layout-raw-slot-metadata layout) (layout-info destruct-layout) (layout-info layout) (classoid-layout classoid) destruct-layout) (setf (layout-invalid layout) nil diff --git a/src/code/condition.lisp b/src/code/condition.lisp index 7f8af8b18..db0e9f615 100644 --- a/src/code/condition.lisp +++ b/src/code/condition.lisp @@ -319,7 +319,7 @@ (layout-length layout) (layout-inherits layout) (layout-depthoid layout) - (layout-n-untagged-slots layout)) + (layout-raw-slot-metadata layout)) (register-layout layout :invalidate t)) ((not (classoid-layout class)) (register-layout layout))) diff --git a/src/code/defbangstruct.lisp b/src/code/defbangstruct.lisp index 2f5ee3f1d..f10249bb3 100644 --- a/src/code/defbangstruct.lisp +++ b/src/code/defbangstruct.lisp @@ -181,7 +181,9 @@ ;; but we must also have cross-compiled it for real. (sb!kernel::compiler-layout-ready-p name) ;; and I don't know anything about raw slots - (zerop (layout-n-untagged-slots + ;; Coincidentally, in either representation of + ;; raw-slot-metadata, 0 represents no untagged slots. + (zerop (layout-raw-slot-metadata (info :type :compiler-layout name))))))) (defun %instance-length (instance) (aver (or (typep instance 'structure!object) diff --git a/src/code/defstruct.lisp b/src/code/defstruct.lisp index dd0886c56..e5666a1c3 100644 --- a/src/code/defstruct.lisp +++ b/src/code/defstruct.lisp @@ -165,7 +165,7 @@ (printer-fname nil :type (or cons symbol)) ;; The number of untagged slots at the end. - (raw-length 0 :type index) + #!-interleaved-raw-slots (raw-length 0 :type index) ;; the value of the :PURE option, or :UNSPECIFIED. This is only ;; meaningful if DD-CLASS-P = T. (pure :unspecified :type (member t nil :unspecified))) @@ -782,23 +782,29 @@ unless :NAMED is also specified."))) ;;; Allocate storage for a DSD in DD. This is where we decide whether ;;; a slot is raw or not. Raw objects are aligned on the unit of their size. (defun allocate-1-slot (dd dsd) - (let ((rsd - (if (eq (dd-type dd) 'structure) - (structure-raw-slot-data (dsd-type dsd)) - nil))) - (cond - ((null rsd) - (setf (dsd-index dsd) (dd-length dd)) - (incf (dd-length dd))) - (t - (let* ((words (raw-slot-data-n-words rsd)) - (alignment (raw-slot-data-alignment rsd)) - (off (rem (dd-raw-length dd) alignment))) - (unless (zerop off) - (incf (dd-raw-length dd) (- alignment off))) - (setf (dsd-raw-type dsd) (raw-slot-data-raw-type rsd)) - (setf (dsd-index dsd) (dd-raw-length dd)) - (incf (dd-raw-length dd) words))))) + (let ((rsd (if (eq (dd-type dd) 'structure) + (structure-raw-slot-data (dsd-type dsd)) + nil))) + (cond ((null rsd) + (setf (dsd-index dsd) (dd-length dd)) + (incf (dd-length dd))) + (t + (setf (dsd-raw-type dsd) (raw-slot-data-raw-type rsd)) + (let ((words (raw-slot-data-n-words rsd)) + (alignment (raw-slot-data-alignment rsd))) + #!-interleaved-raw-slots + (let ((off (rem (dd-raw-length dd) alignment))) + (unless (zerop off) + (incf (dd-raw-length dd) (- alignment off))) + (setf (dsd-index dsd) (dd-raw-length dd)) + (incf (dd-raw-length dd) words)) + #!+interleaved-raw-slots + (let ((len (dd-length dd))) + (setf (dd-length dd) + ;; this formula works but can it be made less unclear? + (- len (nth-value 1 (ceiling (1- len) alignment)))) + (setf (dsd-index dsd) (dd-length dd)) + (incf (dd-length dd) words)))))) (values)) (defun typed-structure-info-or-lose (name) @@ -863,6 +869,7 @@ unless :NAMED is also specified."))) (cons included-name mc)))) (when (eq (dd-pure dd) :unspecified) (setf (dd-pure dd) (dd-pure included-structure))) + #!-interleaved-raw-slots (setf (dd-raw-length dd) (dd-raw-length included-structure))) (setf (dd-inherited-accessor-alist dd) @@ -1234,7 +1241,7 @@ unless :NAMED is also specified."))) (declaim (inline dd-layout-length)) (defun dd-layout-length (dd) - (+ (dd-length dd) (dd-raw-length dd))) + (+ (dd-length dd) #!-interleaved-raw-slots (dd-raw-length dd))) (declaim (ftype (sfunction (defstruct-description) index) dd-instance-length)) (defun dd-instance-length (dd) @@ -1246,6 +1253,18 @@ unless :NAMED is also specified."))) ;; slots, necessary for (at least) the SPARC backend. (logior (dd-layout-length dd) 1)) +(defun dd-bitmap (dd) + ;; The bitmap stores a 1 for each untagged word, + ;; including any internal padding words for alignment. + ;; The 0th bit is initialized to 0 because the LAYOUT is a tagged + ;; slot that is not present in DD-SLOTS. + ;; All other bits start as 1 and are cleared if the word is tagged. + ;; A final padding word, if any, is regarded as tagged. + (let ((bitmap (ldb (byte (dd-length dd) 0) -2))) + (dolist (slot (dd-slots dd) bitmap) + (when (eql t (dsd-raw-type slot)) + (setf (ldb (byte 1 (dsd-index slot)) bitmap) 0))))) + ;;; This is called when we are about to define a structure class. It ;;; returns a (possibly new) class object and the layout which should ;;; be used for the new definition (may be the current layout, and @@ -1284,8 +1303,11 @@ unless :NAMED is also specified."))) :inherits inherits :depthoid (length inherits) :length (dd-layout-length info) - :n-untagged-slots (dd-raw-length info) - :info info)) + :info info + . #!-interleaved-raw-slots + (:n-untagged-slots (dd-raw-length info)) + #!+interleaved-raw-slots + (:untagged-bitmap (dd-bitmap info)))) (old-layout (or compiler-layout old-layout))) (cond ((not old-layout) @@ -1304,7 +1326,7 @@ unless :NAMED is also specified."))) (layout-length new-layout) (layout-inherits new-layout) (layout-depthoid new-layout) - (layout-n-untagged-slots new-layout)) + (layout-raw-slot-metadata new-layout)) (values class new-layout old-layout)) (t (let ((old-info (layout-info old-layout))) diff --git a/src/code/early-raw-slots.lisp b/src/code/early-raw-slots.lisp index 3d2a1fb37..9e1ae187b 100644 --- a/src/code/early-raw-slots.lisp +++ b/src/code/early-raw-slots.lisp @@ -13,6 +13,75 @@ ;;; have any defstructs that use raw slots. %COMPILER-DEFSTRUCT needs the ;;; raw-slot-data-list both at compile-time and load-time. +;;; STRUCTURE-OBJECT supports two different strategies to place raw slots +;;; (containing "just bits", not Lisp descriptors) within it in a way +;;; that GC has knowledge of. No backend supports both strategies though. + +;;; The older strategy is "non-interleaved". +;;; Consider a structure of 3 tagged slots (A,B,C) and 2 raw slots, +;;; where (for simplicity) each raw slot takes space equal to one Lisp word. +;;; (In general raw slots can take >1 word) +;;; Lisp code arranges so that raw slots are last. +;;; Word offsets are listed on the left +;;; 0 : header = (instance-length << 8) | instance-header-widetag +;;; 1 : dsd-index 0 = ptr to LAYOUT +;;; 2 : dsd-index 1 = tagged slot A +;;; 3 : dsd-index 2 = ... B +;;; 4 : dsd-index 3 = ... C +;;; 5 : filler +;;; 6 : dsd-index 1 = second raw slot +;;; 7 : dsd-index 0 = first raw slot +;;; +;;; Note that numbering of raw slots with respect to their DSD-INDEX +;;; restarts at 0, so there are two "spaces" of dsd-indices, the non-raw +;;; and the raw space. Also note that filler was added in the middle, so +;;; that adding INSTANCE-LENGTH to the object's address always gets you +;;; to exactly the 0th raw slot. The filler can't be squeezed out, because +;;; all Lisp objects must consume an even number of words, and the length +;;; of an instance reflects the number of physical - not logical - words +;;; that follow the instance header. +;;; +;;; This strategy for placement of raw slots is easy for GC because GC's +;;; view of an instance is simply some number of boxed words followed by +;;; some number of ignored words. +;;; However, this strategy presents a difficulty for Lisp in that a raw +;;; slot at a given index is not at a fixed offset relative to the base of +;;; the object - it is fixed relative to the _last_ word of the object. +;;; This has to do with the requirement that structure accessors defined by +;;; a parent type work correctly on a descendant type, while preserving the +;;; simple-for-GC aspect. If another DEFSTRUCT says to :INCLUDE the above, +;;; adding two more tagged slots D and E, the slot named D occupies word 5 +;;; ('filler' above), E occupies word 6, and the two raw slots shift down. +;;; To read raw slot at index N requires adding to the object pointer +;;; the number of words represented by instance-length and subtracting the +;;; raw slot index. +;;; Aside from instance-length, the only additional piece of information +;;; that GC needs to know to scavenge a structure is the number of raw slots, +;;; which is obtained from the object's layout in the N-UNTAGGED-SLOTS slot. + +;;; Assuming that it is more important to simplify runtime access than +;;; to simplify GC, we can use the newer strategy, "interleaved" raw slots. +;;; Interleaving freely intermingles tagged data with untagged data +;;; following the layout. This permits descendant structures to add +;;; slots of any kind to the end without changing any physical placement +;;; that was already determined, and eliminates the runtime computation +;;; of the offset to raw slots. It is also generally easier to understand. +;;; The trade-off is that GC (and a few other things - structure dumping, +;;; EQUALP checking, to name a few) have to be able to determine for each +;;; slot whether it is a Lisp descriptor or just bits. This is done +;;; with the LAYOUT-UNTAGGED-BITMAP of an object's layout. +;;; The bitmap stores a '1' for each bit representing a raw word, +;;; and could be a BIGNUM given a spectacularly huge structure. + +;;; Also note that in both strategies there are possibly some alignment +;;; concerns which must be accounted for when DEFSTRUCT lays out slots, +;;; by injecting padding words appropriately. +;;; For example COMPLEX-DOUBLE-FLOAT *should* be aligned to twice the +;;; alignment of a DOUBLE-FLOAT. It is not, as things stand, +;;; but this is considered a minor bug. +;;; Interleaving is supported only on x86-64, but porting should be +;;; straightforward, because if anything the VOPs become simpler. + ;; To utilize a word-sized slot in a defstruct without having to resort to ;; writing (myslot :type (unsigned-byte #.sb!vm:n-word-bits)), or even ;; worse (:type #+sb-xc-host #-sb-xc-host ), @@ -21,6 +90,20 @@ (def!type sb!vm:word () `(unsigned-byte ,sb!vm:n-word-bits)) (def!type sb!vm:signed-word () `(signed-byte ,sb!vm:n-word-bits)) +;; These definitions pertain to how a LAYOUT stores the raw-slot metadata, +;; and we need them before 'class.lisp' is compiled (why, I'm can't remember). +;; LAYOUT-RAW-SLOT-METADATA is an abstraction over whichever kind of +;; metadata we have - it will be one or the other. +#!-interleaved-raw-slots +(progn (deftype layout-raw-slot-metadata-type () 'index) + (defmacro layout-raw-slot-metadata (x) `(layout-n-untagged-slots ,x))) +;; It would be possible to represent an unlimited number of trailing untagged +;; slots (maybe) without consing a bignum if we wished to allow signed integers +;; for the raw slot bitmap, but that's probably confusing and pointless, so... +#!+interleaved-raw-slots +(progn (deftype layout-raw-slot-metadata-type () 'unsigned-byte) + (defmacro layout-raw-slot-metadata (x) `(layout-untagged-bitmap ,x))) + ;; information about how a slot of a given DSD-RAW-TYPE is to be accessed (eval-when (:compile-toplevel :load-toplevel :execute) (defstruct (raw-slot-data @@ -116,3 +199,52 @@ (defun raw-slot-words (type) (raw-slot-data-n-words (raw-slot-data-or-lose type))) + +;; DO-INSTANCE-TAGGED-SLOT will iterate over the slots of THING that +;; contain tagged objects. INDEX-VAR is bound to successive slot-indices, +;; and is usually used as the second argument to %INSTANCE-REF. +;; START, if supplied, should be either 0 or 1 to include, +;; or respectively exclude, the object's layout slot. +;; END, if supplied, represents the upper bound of the scan and should be +;; the LAYOUT-LENGTH of the object; it defaults to %INSTANCE-LENGTH if +;; unsupplied, will therefore possibly include one word that can, in theory, +;; covertly hold one tagged object more than indicated by LAYOUT-LENGTH +;; depending on ODDP of LAYOUT-LENGTH. +;; END works correctly whether or not the backend supports slot interleaving, +;; but it is probably a bug if anyone uses the padding slot for storage. +;; LAYOUT is optional and somewhat unnecessary, but since some uses of +;; this macro already have a layout in hand, it can be supplied. +;; [If the compiler were smarter about doing fewer memory accesses, +;; there would be no need at all for the LAYOUT - if it had already been +;; accessed, it shouldn't be another memory read] +;; Note also that THING is usually a STRUCTURE-OBJECT, not a condition or +;; standard-object. Iterating over a CONDITION means iterating over the +;; slots comprising the primitive representation, not the manifest slots. +;; Similarly for STANDARD-OBJECT. Additionally, in the latter case +;; it would be a bug to specify LAYOUT-LENGTH as the :END parameter. +(defmacro do-instance-tagged-slot ((index-var thing + &key (start 0) end layout) &body body) + (with-unique-names (instance limit bitmap) + (declare (ignorable bitmap)) + (unless layout + (setq layout `(%instance-layout ,instance))) + (unless end + (setq end `(%instance-length ,instance))) + `(let ((,instance ,thing)) + ;; If the macro is given both :LAYOUT and :END, it never uses + ;; the local rebinding of INSTANCE, which is ok. + (declare (ignorable ,instance)) + #!+interleaved-raw-slots + (let ((,bitmap (layout-untagged-bitmap ,layout))) + (do ((,index-var ,start (1+ ,index-var)) + (,limit ,end)) + ((>= ,index-var ,limit)) + (declare (index ,index-var)) + (unless (logbitp ,index-var ,bitmap) + ,@body))) + #!-interleaved-raw-slots + (do ((,index-var ,start (1+ ,index-var)) + (,limit (- ,end (layout-n-untagged-slots ,layout)))) + ((>= ,index-var ,limit)) + (declare (index ,index-var)) + ,@body)))) diff --git a/src/code/fop.lisp b/src/code/fop.lisp index 0c3dc2ca4..38e229900 100644 --- a/src/code/fop.lisp +++ b/src/code/fop.lisp @@ -175,21 +175,32 @@ (n-data-words (1- size))) ; ... and excluding layout (declare (type index size)) (with-fop-stack (stack ptr n-data-words) - (let* ((nuntagged (layout-n-untagged-slots layout)) - (ntagged (- size nuntagged)) - (ptr (+ ptr n-data-words))) + (let ((ptr (+ ptr n-data-words))) + (declare (index ptr)) (setf (%instance-ref res 0) layout) - (dotimes (n (1- ntagged)) - (declare (type index n)) - (setf (%instance-ref res (1+ n)) (fop-stack-ref (decf ptr)))) - (dotimes (n nuntagged) - (declare (type index n)) - (setf (%raw-instance-ref/word res (- nuntagged n 1)) - (fop-stack-ref (decf ptr)))))) + #!-interleaved-raw-slots + (let* ((nuntagged (layout-n-untagged-slots layout)) + (ntagged (- size nuntagged))) + (dotimes (n (1- ntagged)) + (declare (type index n)) + (setf (%instance-ref res (1+ n)) (fop-stack-ref (decf ptr)))) + (dotimes (n nuntagged) + (declare (type index n)) + (setf (%raw-instance-ref/word res (- nuntagged n 1)) + (fop-stack-ref (decf ptr))))) + #!+interleaved-raw-slots + (let ((metadata (layout-untagged-bitmap layout))) + (do ((i 1 (1+ i))) + ((>= i size)) + (declare (type index i)) + (let ((val (fop-stack-ref (decf ptr)))) + (if (logbitp i metadata) + (setf (%raw-instance-ref/word res i) val) + (setf (%instance-ref res i) val))))))) res)) -(define-fop (fop-layout 45 (name inherits depthoid length nuntagged)) - (find-and-init-or-check-layout name length inherits depthoid nuntagged)) +(define-fop (fop-layout 45 (name inherits depthoid length metadata)) + (find-and-init-or-check-layout name length inherits depthoid metadata)) (define-fop (fop-end-group 64 () nil) (/show0 "THROWing FASL-GROUP-END") diff --git a/src/code/pred.lisp b/src/code/pred.lisp index 19986622c..31a4712b3 100644 --- a/src/code/pred.lisp +++ b/src/code/pred.lisp @@ -351,22 +351,43 @@ length and have identical components. Other arrays must be EQ to be EQUAL." (and (hash-table-p y) (hash-table-equalp x y))) ((%instancep x) - (let* ((layout-x (%instance-layout x)) - (raw-len (layout-n-untagged-slots layout-x)) - (total-len (layout-length layout-x)) - (normal-len (- total-len raw-len))) + (let ((layout-x (%instance-layout x))) (and (%instancep y) (eq layout-x (%instance-layout y)) + ;; TODO: store one bit in the layout indicating whether EQUALP + ;; should scan slots. (basically a STRUCTURE-CLASSOID-P bit) (structure-classoid-p (layout-classoid layout-x)) - (dotimes (i normal-len t) - (let ((x-el (%instance-ref x i)) - (y-el (%instance-ref y i))) - (unless (or (eq x-el y-el) - (equalp x-el y-el)) - (return nil)))) - (if (zerop raw-len) - t - (raw-instance-slots-equalp layout-x x y))))) + (macrolet ((slot-ref-equalp () + `(let ((x-el (%instance-ref x i)) + (y-el (%instance-ref y i))) + (or (eq x-el y-el) (equalp x-el y-el))))) + #!-interleaved-raw-slots + (let ((raw-len (layout-n-untagged-slots layout-x)) + (total-len (layout-length layout-x))) + (and (dotimes (i (- total-len raw-len) t) + (unless (slot-ref-equalp) + (return nil))) + (or (zerop raw-len) + (raw-instance-slots-equalp layout-x x y)))) + #!+interleaved-raw-slots + (let ((metadata (layout-untagged-bitmap layout-x))) + (if (zerop metadata) + (loop for i of-type index from 1 + below (layout-length layout-x) + always (slot-ref-equalp)) + (let ((comparators (layout-equalp-tests layout-x))) + (unless (= (length comparators) + (1- (layout-length layout-x))) + (bug "EQUALP got incomplete instance layout")) + ;; See remark at the source code for %TARGET-DEFSTRUCT + ;; explaining how to use the vector of comparators. + (loop for i of-type index from 1 + below (layout-length layout-x) + for test = (data-vector-ref comparators (1- i)) + always (cond ((eql test 0) (slot-ref-equalp)) + ((functionp test) + (funcall test i x y)) + (t)))))))))) ((vectorp x) (let ((length (length x))) (and (vectorp y) diff --git a/src/code/room.lisp b/src/code/room.lisp index feaf76204..b466bd424 100644 --- a/src/code/room.lisp +++ b/src/code/room.lisp @@ -745,8 +745,7 @@ (eq (cdr obj) object)) (maybe-call fun obj))) (instance - (dotimes (i (- (%instance-length obj) - (layout-n-untagged-slots (%instance-layout obj)))) + (do-instance-tagged-slot (i obj) (when (eq (%instance-ref obj i) object) (maybe-call fun obj) (return)))) diff --git a/src/code/sharpm.lisp b/src/code/sharpm.lisp index 751f227d3..d4145e748 100644 --- a/src/code/sharpm.lisp +++ b/src/code/sharpm.lisp @@ -266,16 +266,12 @@ (unless (eq old new) (setf (aref data i) new)))))) ((typep tree 'instance) - (let* ((n-untagged (layout-n-untagged-slots (%instance-layout tree))) - (n-tagged (- (%instance-length tree) n-untagged))) - ;; N-TAGGED includes the layout as well (at index 0), which - ;; we don't grovel. - (do ((i 1 (1+ i))) - ((= i n-tagged)) - (let* ((old (%instance-ref tree i)) - (new (circle-subst old-new-alist old))) - (unless (eq old new) - (setf (%instance-ref tree i) new)))))) + ;; We don't grovel slot index 0, the layout. + (do-instance-tagged-slot (i tree :start 1) + (let* ((old (%instance-ref tree i)) + (new (circle-subst old-new-alist old))) + (unless (eq old new) + (setf (%instance-ref tree i) new))))) ((typep tree 'funcallable-instance) (do ((i 1 (1+ i)) (end (- (1+ (get-closure-length tree)) sb!vm:funcallable-instance-info-offset))) diff --git a/src/code/target-defstruct.lisp b/src/code/target-defstruct.lisp index f0abf98cf..5601d225e 100644 --- a/src/code/target-defstruct.lisp +++ b/src/code/target-defstruct.lisp @@ -138,8 +138,42 @@ (setf (fdocumentation (dd-name dd) 'structure) (dd-doc dd))) - (dolist (fun *defstruct-hooks*) - (funcall fun (find-classoid (dd-name dd)))) + (let* ((classoid (find-classoid (dd-name dd))) + (layout (classoid-layout classoid))) + (declare (ignorable layout)) + #!+interleaved-raw-slots + ;; Make a vector of EQUALP slots comparators, indexed by (1- word-index). + ;; This has to be assigned to something regardless of whether there are + ;; raw slots just in case someone mutates a layout which had raw + ;; slots into one which does not - although that would probably crash + ;; unless no instances exist or all raw slots miraculously contained + ;; bits which were the equivalent of valid Lisp descriptors. + ;; + ;; It's not worth adding a #-interleaved-raw-slots case to this optimization + ;; because every architecture can be made to use the new approach. + (setf (layout-equalp-tests layout) + (if (zerop (layout-untagged-bitmap layout)) + #() + ;; The initial element of NIL means "do not compare". + ;; Ignored words (comparator = NIL) fall into two categories: + ;; - pseudo-ignored, which get compared by their + ;; predecessor word, as for complex-double-float, + ;; - internal padding words which are truly ignored. + ;; Other words are compared as tagged if the comparator is 0, + ;; or as untagged if the comparator is a type-specific function. + (let ((comparators (make-array (1- (dd-length dd)) + :initial-element nil))) + (dolist (slot (dd-slots dd) comparators) + ;; -1 because LAYOUT (slot index 0) has no comparator stored. + (setf (aref comparators (1- (dsd-index slot))) + (let ((raw-type (dsd-raw-type slot))) + (if (eq raw-type t) + 0 ; means recurse using EQUALP + (raw-slot-data-comparer + (raw-slot-data-or-lose raw-type))))))))) + + (dolist (fun *defstruct-hooks*) + (funcall fun classoid))) (/show0 "leaving %TARGET-DEFSTRUCT") (values)) @@ -149,33 +183,51 @@ #!+sb-doc "Return a copy of STRUCTURE with the same (EQL) slot values." (declare (type structure-object structure)) - (let* ((layout (%instance-layout structure)) - (res (%make-instance (%instance-length structure))) - (len (layout-length layout)) - (nuntagged (layout-n-untagged-slots layout))) - - (declare (type index len)) + (let ((layout (%instance-layout structure))) (when (layout-invalid layout) (error "attempt to copy an obsolete structure:~% ~S" structure)) - - ;; Copy ordinary slots and layout. - (dotimes (i (- len nuntagged)) - (declare (type index i)) - (setf (%instance-ref res i) - (%instance-ref structure i))) - - ;; Copy raw slots. - (dotimes (i nuntagged) - (declare (type index i)) - (setf (%raw-instance-ref/word res i) - (%raw-instance-ref/word structure i))) - - res)) - + (let ((res (%make-instance (%instance-length structure))) + (len (layout-length layout))) + (declare (type index len)) + #!-interleaved-raw-slots + (let ((nuntagged (layout-n-untagged-slots layout))) + ;; Copy ordinary slots including the layout. + (dotimes (i (- len nuntagged)) + (declare (type index i)) + (setf (%instance-ref res i) (%instance-ref structure i))) + ;; Copy raw slots. + (dotimes (i nuntagged) + (declare (type index i)) + (setf (%raw-instance-ref/word res i) + (%raw-instance-ref/word structure i)))) + #!+interleaved-raw-slots + (let ((metadata (layout-untagged-bitmap layout))) + ;; With interleaved slots, the only difference between %instance-ref + ;; and %raw-instance-ref/word is the storage class of the VOP operands. + ;; Since x86(-64) doesn't partition the register set, the bitmap test + ;; could be skipped if we wanted to copy everything as raw. + (macrolet ((copy-loop (raw-p &optional step) + `(dotimes (i (layout-length layout)) + (if ,raw-p + (setf (%raw-instance-ref/word res i) + (%raw-instance-ref/word structure i)) + (setf (%instance-ref res i) + (%instance-ref structure i))) + ,step))) + (cond ((zerop metadata) ; no untagged slots. + (dotimes (i len) + (setf (%instance-ref res i) (%instance-ref structure i)))) + ;; The fixnum case uses fixnum operations for ODPP and ASH. + ((fixnump metadata) ; shift and mask is faster than logbitp + (copy-loop (oddp metadata) (setq metadata (ash metadata -1)))) + (t ; bignum - use LOGBITP to avoid consing more bignums + (copy-loop (logbitp i metadata)))))) + res))) ;; Do an EQUALP comparison on the raw slots (only, not the normal slots) of a ;; structure. +#!-interleaved-raw-slots (defun raw-instance-slots-equalp (layout x y) ;; This implementation sucks, but hopefully EQUALP on raw structures ;; won't be a major bottleneck for anyone. It'd be tempting to do diff --git a/src/code/target-sxhash.lisp b/src/code/target-sxhash.lisp index fe9ad77ba..be00889bc 100644 --- a/src/code/target-sxhash.lisp +++ b/src/code/target-sxhash.lisp @@ -340,18 +340,28 @@ (declare (type structure-object key)) (declare (type (integer 0 #.+max-hash-depthoid+) depthoid)) (let* ((layout (%instance-layout key)) ; i.e. slot #0 - (length (layout-length layout)) + ;; Is there some reason the name of the layout's classoid + ;; should be preferred as the seed, instead of using the CLOS-HASH + ;; just like SXHASH does? (classoid (layout-classoid layout)) (name (classoid-name classoid)) (result (mix (sxhash name) (the fixnum 79867)))) (declare (type fixnum result)) - (dotimes (i (min depthoid (- length 1 (layout-n-untagged-slots layout)))) - (declare (type fixnum i)) - (let ((j (1+ i))) ; skipping slot #0, which is for LAYOUT - (declare (type fixnum j)) - (mixf result - (psxhash (%instance-ref key j) - (1- depthoid))))) + (when (plusp depthoid) + (let ((max-iterations depthoid) + (depthoid (1- depthoid))) + ;; skipping slot #0, which is for LAYOUT + (do-instance-tagged-slot (i key :layout layout + :start 1 :end (layout-length layout)) + (mixf result (psxhash (%instance-ref key i) depthoid)) + (if (zerop (decf max-iterations)) (return))))) + ;; [The following comment blurs some issues: indeed it would take + ;; a second loop in the non-interleaved-slots code; that loop might + ;; never execute because depthoid "cuts off", although that's an arbitrary + ;; choice and could be decided otherwise; and efficiency would likely + ;; demand that we store some additional metadata in the LAYOUT indicating + ;; how to mix the bits in, because floating-point +/-zeros have to + ;; be considered EQUALP] ;; KLUDGE: Should hash untagged slots, too. (Although +max-hash-depthoid+ ;; is pretty low currently, so they might not make it into the hash ;; value anyway.) diff --git a/src/compiler/dump.lisp b/src/compiler/dump.lisp index b7220bb14..f17015a4d 100644 --- a/src/compiler/dump.lisp +++ b/src/compiler/dump.lisp @@ -1278,14 +1278,22 @@ (note-potential-circularity struct file) (aver (%instance-ref struct 0)) (do* ((length (%instance-length struct)) + #!-interleaved-raw-slots (ntagged (- length (layout-n-untagged-slots (%instance-ref struct 0)))) + #!+interleaved-raw-slots + (bitmap (layout-untagged-bitmap (%instance-ref struct 0))) (circ (fasl-output-circularity-table file)) ;; last slot first on the stack, so that the layout is on top: (index (1- length) (1- index))) ((minusp index) (dump-fop* length fop-small-struct fop-struct file)) - (let* ((obj (if (>= index ntagged) + (let* ((obj #!-interleaved-raw-slots + (if (>= index ntagged) (%raw-instance-ref/word struct (- length index 1)) + (%instance-ref struct index)) + #!+interleaved-raw-slots + (if (logbitp index bitmap) + (%raw-instance-ref/word struct index) (%instance-ref struct index))) (ref (gethash obj circ))) (cond (ref @@ -1311,5 +1319,5 @@ (sub-dump-object (layout-inherits obj) file) (sub-dump-object (layout-depthoid obj) file) (sub-dump-object (layout-length obj) file) - (sub-dump-object (layout-n-untagged-slots obj) file) + (sub-dump-object (layout-raw-slot-metadata obj) file) (dump-fop 'fop-layout file)) diff --git a/src/compiler/fopcompile.lisp b/src/compiler/fopcompile.lisp index 683c70c64..b0a19e30c 100644 --- a/src/compiler/fopcompile.lisp +++ b/src/compiler/fopcompile.lisp @@ -227,9 +227,7 @@ ;; it we bind *dump-only-valid-structures* to ;; NIL. (fasl-validate-structure value *compile-object*) - (dotimes (i (- (%instance-length value) - (layout-n-untagged-slots - (%instance-ref value 0)))) + (do-instance-tagged-slot (i value) (grovel (%instance-ref value i)))) (:ignore-it) (t diff --git a/src/compiler/generic/genesis.lisp b/src/compiler/generic/genesis.lisp index 807200918..df6e81379 100644 --- a/src/compiler/generic/genesis.lisp +++ b/src/compiler/generic/genesis.lisp @@ -810,6 +810,9 @@ core and return a descriptor to it." ;;; Make a simple-vector on the target that holds the specified ;;; OBJECTS, and return its descriptor. +;;; Oops, this function was renamed (by me) for the wrong reason - that it +;;; was unharmonious with other -TO-CORE functions, however X-TO-CORE +;;; should accept an argument of type X which this doesn't (FIXME). (defun vector-to-core (objects &optional (gspace *dynamic*)) (let* ((size (length objects)) (result (allocate-vector-object gspace sb!vm:n-word-bits size @@ -1001,10 +1004,11 @@ core and return a descriptor to it." (descriptor-bits des))))) (res)))) +(defvar *simple-vector-0-descriptor*) (declaim (ftype (function (symbol descriptor descriptor descriptor descriptor) descriptor) make-cold-layout)) -(defun make-cold-layout (name length inherits depthoid nuntagged) +(defun make-cold-layout (name length inherits depthoid metadata) (let ((result (allocate-structure-object *dynamic* target-layout-length *layout-layout*))) @@ -1019,7 +1023,16 @@ core and return a descriptor to it." (cold-set-layout-slot result 'length length) (cold-set-layout-slot result 'info *nil-descriptor*) (cold-set-layout-slot result 'pure *nil-descriptor*) - (cold-set-layout-slot result 'n-untagged-slots nuntagged) + #!-interleaved-raw-slots + (cold-set-layout-slot result 'n-untagged-slots metadata) + #!+interleaved-raw-slots + (progn + (cold-set-layout-slot result 'untagged-bitmap metadata) + ;; Nothing in cold-init needs to call EQUALP on a structure with raw slots, + ;; but for type-correctness this slot needs to be a simple-vector. + (unless (boundp '*simple-vector-0-descriptor*) + (setq *simple-vector-0-descriptor* (vector-to-core nil))) + (cold-set-layout-slot result 'equalp-tests *simple-vector-0-descriptor*)) (cold-set-layout-slot result 'source-location *nil-descriptor*) (cold-set-layout-slot result '%for-std-class-b (make-fixnum-descriptor 0)) (cold-set-layout-slot result 'slot-list *nil-descriptor*) @@ -1030,7 +1043,7 @@ core and return a descriptor to it." (descriptor-fixnum length) (listify-cold-inherits inherits) (descriptor-fixnum depthoid) - (descriptor-fixnum nuntagged))) + (descriptor-fixnum metadata))) (setf (gethash (descriptor-bits result) *cold-layout-names*) name) result)) @@ -1039,7 +1052,7 @@ core and return a descriptor to it." (clrhash *cold-layouts*) ;; This assertion is due to the fact that MAKE-COLD-LAYOUT does not ;; know how to set any raw slots. - (aver (= 0 (layout-n-untagged-slots (find-layout 'layout)))) + (aver (= 0 (layout-raw-slot-metadata (find-layout 'layout)))) (setq *layout-layout* *nil-descriptor*) (flet ((chill-layout (name &rest inherits) ;; Check that the number of specified INHERITS matches @@ -1052,7 +1065,7 @@ core and return a descriptor to it." (number-to-core (layout-length warm-layout)) (vector-to-core inherits) (number-to-core (layout-depthoid warm-layout)) - (number-to-core (layout-n-untagged-slots warm-layout)))))) + (number-to-core (layout-raw-slot-metadata warm-layout)))))) (let* ((t-layout (chill-layout 't)) (s-o-layout (chill-layout 'structure-object t-layout)) (s!o-layout (chill-layout 'structure!object t-layout s-o-layout))) @@ -2137,25 +2150,33 @@ core and return a descriptor to it." (let* ((size (clone-arg)) ; n-words including layout, excluding header (layout (pop-stack)) (result (allocate-structure-object *dynamic* size layout)) - (nuntagged + (metadata (descriptor-fixnum (read-wordindexed layout (+ sb!vm:instance-slots-offset - (target-layout-index 'n-untagged-slots))))) - (ntagged (- size nuntagged))) + (target-layout-index + #!-interleaved-raw-slots 'n-untagged-slots + #!+interleaved-raw-slots 'untagged-bitmap))))) + #!-interleaved-raw-slots (ntagged (- size metadata)) + ) + #!+interleaved-raw-slots + (unless (= metadata 0) + (error "Interleaved raw slots not (yet) known to work in genesis.")) + (do ((index 1 (1+ index))) ((eql index size)) (declare (fixnum index)) (write-wordindexed result (+ index sb!vm:instance-slots-offset) - (if (>= index ntagged) + (if #!-interleaved-raw-slots (>= index ntagged) + #!+interleaved-raw-slots (logbitp index metadata) (descriptor-word-sized-integer (pop-stack)) (pop-stack)))) result)) (define-cold-fop (fop-layout) - (let* ((nuntagged-des (pop-stack)) + (let* ((metadata-des (pop-stack)) (length-des (pop-stack)) (depthoid-des (pop-stack)) (cold-inherits (pop-stack)) @@ -2175,17 +2196,18 @@ core and return a descriptor to it." old-length old-inherits-list old-depthoid - old-nuntagged) + old-metadata) old (declare (type descriptor old-layout-descriptor)) - (declare (type index old-length old-nuntagged)) - (declare (type fixnum old-depthoid)) + (declare (type index old-length)) (declare (type list old-inherits-list)) + (declare (type fixnum old-depthoid)) + (declare (type unsigned-byte old-metadata)) (aver (eq name old-name)) (let ((length (descriptor-fixnum length-des)) (inherits-list (listify-cold-inherits cold-inherits)) (depthoid (descriptor-fixnum depthoid-des)) - (nuntagged (descriptor-fixnum nuntagged-des))) + (metadata (descriptor-fixnum metadata-des))) (unless (= length old-length) (error "cold loading a reference to class ~S when the compile~%~ time length was ~S and current length is ~S" @@ -2206,16 +2228,16 @@ core and return a descriptor to it." name depthoid old-depthoid)) - (unless (= nuntagged old-nuntagged) + (unless (= metadata old-metadata) (error "cold loading a reference to class ~S when the compile~%~ - time number of untagged slots was ~S and is currently ~S" + time raw-slot-metadata was ~S and is currently ~S" name - nuntagged - old-nuntagged))) + metadata + old-metadata))) old-layout-descriptor) ;; Make a new definition from scratch. (make-cold-layout name length-des cold-inherits depthoid-des - nuntagged-des)))) + metadata-des)))) ;;;; cold fops for loading symbols @@ -3062,13 +3084,31 @@ core and return a descriptor to it." (format t "struct ~A {~%" (cstring (dd-name dd))) (format t " lispobj header;~%") (format t " lispobj layout;~%") - (dolist (slot (dd-slots dd)) - (when (eq t (dsd-raw-type slot)) - (format t " lispobj ~A;~%" (cstring (dsd-name slot))))) - (unless (oddp (+ (dd-length dd) (dd-raw-length dd))) - (format t " lispobj raw_slot_padding;~%")) - (dotimes (n (dd-raw-length dd)) - (format t " lispobj raw~D;~%" (- (dd-raw-length dd) n 1))) + #!-interleaved-raw-slots + (progn + ;; Note: if the structure has no raw slots, but has an even number of + ;; ordinary slots (incl. layout, sans header), then the last slot gets + ;; named 'raw_slot_paddingN' (not 'paddingN') + ;; The choice of name is mildly disturbing, but harmless. + (dolist (slot (dd-slots dd)) + (when (eq t (dsd-raw-type slot)) + (format t " lispobj ~A;~%" (cstring (dsd-name slot))))) + (unless (oddp (+ (dd-length dd) (dd-raw-length dd))) + (format t " lispobj raw_slot_padding;~%")) + (dotimes (n (dd-raw-length dd)) + (format t " lispobj raw~D;~%" (- (dd-raw-length dd) n 1)))) + #!+interleaved-raw-slots + (let ((index 1)) + (dolist (slot (dd-slots dd)) + (cond ((eq t (dsd-raw-type slot)) + (loop while (< index (dsd-index slot)) + do + (format t " lispobj raw_slot_padding~A;~%" index) + (incf index)) + (format t " lispobj ~A;~%" (cstring (dsd-name slot))) + (incf index)))) + (unless (oddp (dd-length dd)) + (format t " lispobj end_padding;~%"))) (format t "};~2%") (format t "#endif /* LANGUAGE_ASSEMBLY */~2%"))) diff --git a/src/compiler/generic/vm-ir2tran.lisp b/src/compiler/generic/vm-ir2tran.lisp index f5ab1b475..df2edc3d1 100644 --- a/src/compiler/generic/vm-ir2tran.lisp +++ b/src/compiler/generic/vm-ir2tran.lisp @@ -68,6 +68,7 @@ (move-lvar-result node block locs lvar))) (defun emit-inits (node block name object lowtag instance-length inits args) + #!+interleaved-raw-slots (declare (ignore instance-length)) #!-raw-instance-init-vops (declare (ignore instance-length)) (let ((unbound-marker-tn nil) @@ -101,7 +102,9 @@ (setf arg-tn tmp))) (vop ,(sb!kernel::raw-slot-data-init-vop rsd) node block - object arg-tn instance-length slot))))) + object arg-tn + #!-interleaved-raw-slots instance-length + slot))))) #!+raw-instance-init-vops sb!kernel::*raw-slot-data-list* #!-raw-instance-init-vops diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp index 0df417256..165a7f492 100644 --- a/src/compiler/ir1tran.lisp +++ b/src/compiler/ir1tran.lisp @@ -360,6 +360,17 @@ ;; FIXME: What about funcallable instances with ;; user-defined MAKE-LOAD-FORM methods? (when (emit-make-load-form value) + ;; "#+sb-xc-host 0" is actually necessary. + ;; DO-INSTANCE-TAGGED-SLOT does not work here + ;; due to a build order issue. + #!+interleaved-raw-slots + (let ((bitmap #+sb-xc-host 0 + #-sb-xc-host (layout-untagged-bitmap + (%instance-ref value 0)))) + (dotimes (i (%instance-length value)) + (unless (logbitp i bitmap) + (grovel (%instance-ref value i))))) + #!-interleaved-raw-slots (dotimes (i (- (%instance-length value) #+sb-xc-host 0 #-sb-xc-host (layout-n-untagged-slots diff --git a/src/compiler/x86-64/cell.lisp b/src/compiler/x86-64/cell.lisp index cf3d819fe..784814c9c 100644 --- a/src/compiler/x86-64/cell.lisp +++ b/src/compiler/x86-64/cell.lisp @@ -597,45 +597,31 @@ ;;;; raw instance slot accessors -(defun make-ea-for-raw-slot (object instance-length - &key (index nil) (adjustment 0) (scale 1)) - (if (integerp instance-length) - ;; For RAW-INSTANCE-INIT/* VOPs, which know the exact instance length - ;; at compile time. - (make-ea :qword - :base object - :disp (+ (* (- instance-length instance-slots-offset index) - n-word-bytes) - (- instance-pointer-lowtag) - adjustment)) - (etypecase index - (null - (make-ea :qword :base object :index instance-length :scale scale - :disp (+ (* (1- instance-slots-offset) n-word-bytes) - (- instance-pointer-lowtag) - adjustment))) - (integer - (make-ea :qword :base object :index instance-length - :scale 8 - :disp (+ (* (1- instance-slots-offset) n-word-bytes) - (- instance-pointer-lowtag) - adjustment - (* index (- n-word-bytes)))))))) +(defun make-ea-for-raw-slot (object index) + (etypecase index + (integer + (make-ea :qword + :base object + :disp (+ (* (+ instance-slots-offset index) + n-word-bytes) + (- instance-pointer-lowtag)))) + (tn + (make-ea :qword + :base object + :index index + :scale (ash 1 (- word-shift n-fixnum-tag-bits)) + :disp (+ (* instance-slots-offset n-word-bytes) + (- instance-pointer-lowtag)))))) (define-vop (raw-instance-ref/word) (:translate %raw-instance-ref/word) (:policy :fast-safe) (:args (object :scs (descriptor-reg)) (index :scs (any-reg))) (:arg-types * tagged-num) - (:temporary (:sc unsigned-reg) tmp) (:results (value :scs (unsigned-reg))) (:result-types unsigned-num) (:generator 5 - (loadw tmp object 0 instance-pointer-lowtag) - (inst shr tmp n-widetag-bits) - (inst shl tmp n-fixnum-tag-bits) - (inst sub tmp index) - (inst mov value (make-ea-for-raw-slot object tmp :scale (ash 1 (- word-shift n-fixnum-tag-bits)))))) + (inst mov value (make-ea-for-raw-slot object index)))) (define-vop (raw-instance-ref-c/word) (:translate %raw-instance-ref/word) @@ -645,13 +631,10 @@ #.instance-pointer-lowtag #.instance-slots-offset))) (:info index) - (:temporary (:sc unsigned-reg) tmp) (:results (value :scs (unsigned-reg))) (:result-types unsigned-num) (:generator 4 - (loadw tmp object 0 instance-pointer-lowtag) - (inst shr tmp n-widetag-bits) - (inst mov value (make-ea-for-raw-slot object tmp :index index)))) + (inst mov value (make-ea-for-raw-slot object index)))) (define-vop (raw-instance-set/word) (:translate %raw-instance-set/word) @@ -660,15 +643,10 @@ (index :scs (any-reg)) (value :scs (unsigned-reg) :target result)) (:arg-types * tagged-num unsigned-num) - (:temporary (:sc unsigned-reg) tmp) (:results (result :scs (unsigned-reg))) (:result-types unsigned-num) (:generator 5 - (loadw tmp object 0 instance-pointer-lowtag) - (inst shr tmp n-widetag-bits) - (inst shl tmp n-fixnum-tag-bits) - (inst sub tmp index) - (inst mov (make-ea-for-raw-slot object tmp :scale (ash 1 (- word-shift n-fixnum-tag-bits))) value) + (inst mov (make-ea-for-raw-slot object index) value) (move result value))) (define-vop (raw-instance-set-c/word) @@ -681,22 +659,19 @@ #.instance-slots-offset)) unsigned-num) (:info index) - (:temporary (:sc unsigned-reg) tmp) (:results (result :scs (unsigned-reg))) (:result-types unsigned-num) (:generator 4 - (loadw tmp object 0 instance-pointer-lowtag) - (inst shr tmp n-widetag-bits) - (inst mov (make-ea-for-raw-slot object tmp :index index) value) + (inst mov (make-ea-for-raw-slot object index) value) (move result value))) (define-vop (raw-instance-init/word) (:args (object :scs (descriptor-reg)) (value :scs (unsigned-reg))) (:arg-types * unsigned-num) - (:info instance-length index) + (:info index) (:generator 4 - (inst mov (make-ea-for-raw-slot object instance-length :index index) value))) + (inst mov (make-ea-for-raw-slot object index) value))) (define-vop (raw-instance-atomic-incf/word) (:translate %raw-instance-atomic-incf/word) @@ -705,16 +680,10 @@ (index :scs (any-reg)) (diff :scs (unsigned-reg) :target result)) (:arg-types * tagged-num unsigned-num) - (:temporary (:sc unsigned-reg) tmp) (:results (result :scs (unsigned-reg))) (:result-types unsigned-num) (:generator 5 - (loadw tmp object 0 instance-pointer-lowtag) - (inst shr tmp n-widetag-bits) - (inst shl tmp n-fixnum-tag-bits) - (inst sub tmp index) - (inst xadd (make-ea-for-raw-slot object tmp :scale (ash 1 (- word-shift n-fixnum-tag-bits))) - diff :lock) + (inst xadd (make-ea-for-raw-slot object index) diff :lock) (move result diff))) (define-vop (raw-instance-atomic-incf-c/word) @@ -727,13 +696,10 @@ #.instance-slots-offset)) unsigned-num) (:info index) - (:temporary (:sc unsigned-reg) tmp) (:results (result :scs (unsigned-reg))) (:result-types unsigned-num) (:generator 4 - (loadw tmp object 0 instance-pointer-lowtag) - (inst shr tmp n-widetag-bits) - (inst xadd (make-ea-for-raw-slot object tmp :index index) diff :lock) + (inst xadd (make-ea-for-raw-slot object index) diff :lock) (move result diff))) (define-vop (raw-instance-ref/single) @@ -742,15 +708,10 @@ (:args (object :scs (descriptor-reg)) (index :scs (any-reg))) (:arg-types * positive-fixnum) - (:temporary (:sc unsigned-reg) tmp) (:results (value :scs (single-reg))) (:result-types single-float) (:generator 5 - (loadw tmp object 0 instance-pointer-lowtag) - (inst shr tmp n-widetag-bits) - (inst shl tmp n-fixnum-tag-bits) - (inst sub tmp index) - (inst movss value (make-ea-for-raw-slot object tmp :scale (ash 1 (- word-shift n-fixnum-tag-bits)))))) + (inst movss value (make-ea-for-raw-slot object index)))) (define-vop (raw-instance-ref-c/single) (:translate %raw-instance-ref/single) @@ -760,13 +721,10 @@ #.instance-pointer-lowtag #.instance-slots-offset))) (:info index) - (:temporary (:sc unsigned-reg) tmp) (:results (value :scs (single-reg))) (:result-types single-float) (:generator 4 - (loadw tmp object 0 instance-pointer-lowtag) - (inst shr tmp n-widetag-bits) - (inst movss value (make-ea-for-raw-slot object tmp :index index)))) + (inst movss value (make-ea-for-raw-slot object index)))) (define-vop (raw-instance-set/single) (:translate %raw-instance-set/single) @@ -775,15 +733,10 @@ (index :scs (any-reg)) (value :scs (single-reg) :target result)) (:arg-types * positive-fixnum single-float) - (:temporary (:sc unsigned-reg) tmp) (:results (result :scs (single-reg))) (:result-types single-float) (:generator 5 - (loadw tmp object 0 instance-pointer-lowtag) - (inst shr tmp n-widetag-bits) - (inst shl tmp n-fixnum-tag-bits) - (inst sub tmp index) - (inst movss (make-ea-for-raw-slot object tmp :scale (ash 1 (- word-shift n-fixnum-tag-bits))) value) + (inst movss (make-ea-for-raw-slot object index) value) (move result value))) (define-vop (raw-instance-set-c/single) @@ -796,22 +749,19 @@ #.instance-slots-offset)) single-float) (:info index) - (:temporary (:sc unsigned-reg) tmp) (:results (result :scs (single-reg))) (:result-types single-float) (:generator 4 - (loadw tmp object 0 instance-pointer-lowtag) - (inst shr tmp n-widetag-bits) - (inst movss (make-ea-for-raw-slot object tmp :index index) value) + (inst movss (make-ea-for-raw-slot object index) value) (move result value))) (define-vop (raw-instance-init/single) (:args (object :scs (descriptor-reg)) (value :scs (single-reg))) (:arg-types * single-float) - (:info instance-length index) + (:info index) (:generator 4 - (inst movss (make-ea-for-raw-slot object instance-length :index index) value))) + (inst movss (make-ea-for-raw-slot object index) value))) (define-vop (raw-instance-ref/double) (:translate %raw-instance-ref/double) @@ -819,15 +769,10 @@ (:args (object :scs (descriptor-reg)) (index :scs (any-reg))) (:arg-types * positive-fixnum) - (:temporary (:sc unsigned-reg) tmp) (:results (value :scs (double-reg))) (:result-types double-float) (:generator 5 - (loadw tmp object 0 instance-pointer-lowtag) - (inst shr tmp n-widetag-bits) - (inst shl tmp n-fixnum-tag-bits) - (inst sub tmp index) - (inst movsd value (make-ea-for-raw-slot object tmp :scale (ash 1 (- word-shift n-fixnum-tag-bits)))))) + (inst movsd value (make-ea-for-raw-slot object index)))) (define-vop (raw-instance-ref-c/double) (:translate %raw-instance-ref/double) @@ -837,13 +782,10 @@ #.instance-pointer-lowtag #.instance-slots-offset))) (:info index) - (:temporary (:sc unsigned-reg) tmp) (:results (value :scs (double-reg))) (:result-types double-float) (:generator 4 - (loadw tmp object 0 instance-pointer-lowtag) - (inst shr tmp n-widetag-bits) - (inst movsd value (make-ea-for-raw-slot object tmp :index index)))) + (inst movsd value (make-ea-for-raw-slot object index)))) (define-vop (raw-instance-set/double) (:translate %raw-instance-set/double) @@ -852,15 +794,10 @@ (index :scs (any-reg)) (value :scs (double-reg) :target result)) (:arg-types * positive-fixnum double-float) - (:temporary (:sc unsigned-reg) tmp) (:results (result :scs (double-reg))) (:result-types double-float) (:generator 5 - (loadw tmp object 0 instance-pointer-lowtag) - (inst shr tmp n-widetag-bits) - (inst shl tmp n-fixnum-tag-bits) - (inst sub tmp index) - (inst movsd (make-ea-for-raw-slot object tmp :scale (ash 1 (- word-shift n-fixnum-tag-bits))) value) + (inst movsd (make-ea-for-raw-slot object index) value) (move result value))) (define-vop (raw-instance-set-c/double) @@ -873,22 +810,19 @@ #.instance-slots-offset)) double-float) (:info index) - (:temporary (:sc unsigned-reg) tmp) (:results (result :scs (double-reg))) (:result-types double-float) (:generator 4 - (loadw tmp object 0 instance-pointer-lowtag) - (inst shr tmp n-widetag-bits) - (inst movsd (make-ea-for-raw-slot object tmp :index index) value) + (inst movsd (make-ea-for-raw-slot object index) value) (move result value))) (define-vop (raw-instance-init/double) (:args (object :scs (descriptor-reg)) (value :scs (double-reg))) (:arg-types * double-float) - (:info instance-length index) + (:info index) (:generator 4 - (inst movsd (make-ea-for-raw-slot object instance-length :index index) value))) + (inst movsd (make-ea-for-raw-slot object index) value))) (define-vop (raw-instance-ref/complex-single) (:translate %raw-instance-ref/complex-single) @@ -896,15 +830,10 @@ (:args (object :scs (descriptor-reg)) (index :scs (any-reg))) (:arg-types * positive-fixnum) - (:temporary (:sc unsigned-reg) tmp) (:results (value :scs (complex-single-reg))) (:result-types complex-single-float) (:generator 5 - (loadw tmp object 0 instance-pointer-lowtag) - (inst shr tmp n-widetag-bits) - (inst shl tmp n-fixnum-tag-bits) - (inst sub tmp index) - (inst movq value (make-ea-for-raw-slot object tmp :scale (ash 1 (- word-shift n-fixnum-tag-bits)))))) + (inst movq value (make-ea-for-raw-slot object index)))) (define-vop (raw-instance-ref-c/complex-single) (:translate %raw-instance-ref/complex-single) @@ -914,13 +843,10 @@ #.instance-pointer-lowtag #.instance-slots-offset))) (:info index) - (:temporary (:sc unsigned-reg) tmp) (:results (value :scs (complex-single-reg))) (:result-types complex-single-float) (:generator 4 - (loadw tmp object 0 instance-pointer-lowtag) - (inst shr tmp n-widetag-bits) - (inst movq value (make-ea-for-raw-slot object tmp :index index)))) + (inst movq value (make-ea-for-raw-slot object index)))) (define-vop (raw-instance-set/complex-single) (:translate %raw-instance-set/complex-single) @@ -929,16 +855,11 @@ (index :scs (any-reg)) (value :scs (complex-single-reg) :target result)) (:arg-types * positive-fixnum complex-single-float) - (:temporary (:sc unsigned-reg) tmp) (:results (result :scs (complex-single-reg))) (:result-types complex-single-float) (:generator 5 - (loadw tmp object 0 instance-pointer-lowtag) - (inst shr tmp n-widetag-bits) - (inst shl tmp n-fixnum-tag-bits) - (inst sub tmp index) (move result value) - (inst movq (make-ea-for-raw-slot object tmp :scale (ash 1 (- word-shift n-fixnum-tag-bits))) value))) + (inst movq (make-ea-for-raw-slot object index) value))) (define-vop (raw-instance-set-c/complex-single) (:translate %raw-instance-set/complex-single) @@ -950,22 +871,19 @@ #.instance-slots-offset)) complex-single-float) (:info index) - (:temporary (:sc unsigned-reg) tmp) (:results (result :scs (complex-single-reg))) (:result-types complex-single-float) (:generator 4 - (loadw tmp object 0 instance-pointer-lowtag) - (inst shr tmp n-widetag-bits) (move result value) - (inst movq (make-ea-for-raw-slot object tmp :index index) value))) + (inst movq (make-ea-for-raw-slot object index) value))) (define-vop (raw-instance-init/complex-single) (:args (object :scs (descriptor-reg)) (value :scs (complex-single-reg))) (:arg-types * complex-single-float) - (:info instance-length index) + (:info index) (:generator 4 - (inst movq (make-ea-for-raw-slot object instance-length :index index) value))) + (inst movq (make-ea-for-raw-slot object index) value))) (define-vop (raw-instance-ref/complex-double) (:translate %raw-instance-ref/complex-double) @@ -973,15 +891,10 @@ (:args (object :scs (descriptor-reg)) (index :scs (any-reg))) (:arg-types * positive-fixnum) - (:temporary (:sc unsigned-reg) tmp) (:results (value :scs (complex-double-reg))) (:result-types complex-double-float) (:generator 5 - (loadw tmp object 0 instance-pointer-lowtag) - (inst shr tmp n-widetag-bits) - (inst shl tmp n-fixnum-tag-bits) - (inst sub tmp index) - (inst movdqu value (make-ea-for-raw-slot object tmp :scale (ash 1 (- word-shift n-fixnum-tag-bits)) :adjustment -8)))) + (inst movdqu value (make-ea-for-raw-slot object index)))) (define-vop (raw-instance-ref-c/complex-double) (:translate %raw-instance-ref/complex-double) @@ -991,13 +904,10 @@ #.instance-pointer-lowtag #.instance-slots-offset))) (:info index) - (:temporary (:sc unsigned-reg) tmp) (:results (value :scs (complex-double-reg))) (:result-types complex-double-float) (:generator 4 - (loadw tmp object 0 instance-pointer-lowtag) - (inst shr tmp n-widetag-bits) - (inst movdqu value (make-ea-for-raw-slot object tmp :index index :adjustment -8)))) + (inst movdqu value (make-ea-for-raw-slot object index)))) (define-vop (raw-instance-set/complex-double) (:translate %raw-instance-set/complex-double) @@ -1006,16 +916,11 @@ (index :scs (any-reg)) (value :scs (complex-double-reg) :target result)) (:arg-types * positive-fixnum complex-double-float) - (:temporary (:sc unsigned-reg) tmp) (:results (result :scs (complex-double-reg))) (:result-types complex-double-float) (:generator 5 - (loadw tmp object 0 instance-pointer-lowtag) - (inst shr tmp n-widetag-bits) - (inst shl tmp n-fixnum-tag-bits) - (inst sub tmp index) (move result value) - (inst movdqu (make-ea-for-raw-slot object tmp :scale (ash 1 (- word-shift n-fixnum-tag-bits)) :adjustment -8) value))) + (inst movdqu (make-ea-for-raw-slot object index) value))) (define-vop (raw-instance-set-c/complex-double) (:translate %raw-instance-set/complex-double) @@ -1027,19 +932,16 @@ #.instance-slots-offset)) complex-double-float) (:info index) - (:temporary (:sc unsigned-reg) tmp) (:results (result :scs (complex-double-reg))) (:result-types complex-double-float) (:generator 4 - (loadw tmp object 0 instance-pointer-lowtag) - (inst shr tmp n-widetag-bits) (move result value) - (inst movdqu (make-ea-for-raw-slot object tmp :index index :adjustment -8) value))) + (inst movdqu (make-ea-for-raw-slot object index) value))) (define-vop (raw-instance-init/complex-double) (:args (object :scs (descriptor-reg)) (value :scs (complex-double-reg))) (:arg-types * complex-double-float) - (:info instance-length index) + (:info index) (:generator 4 - (inst movdqu (make-ea-for-raw-slot object instance-length :index index :adjustment -8) value))) + (inst movdqu (make-ea-for-raw-slot object index) value))) diff --git a/src/runtime/gc-common.c b/src/runtime/gc-common.c index 9e22fe2ba..9d72ca60a 100644 --- a/src/runtime/gc-common.c +++ b/src/runtime/gc-common.c @@ -669,20 +669,92 @@ scav_boxed(lispobj *where, lispobj object) return 1; } +#ifdef LISP_FEATURE_INTERLEAVED_RAW_SLOTS +boolean positive_bignum_logbitp(int index, struct bignum* bignum) +{ + /* If the bignum in the layout has another pointer to it (besides the layout) + acting as a root, and which is scavenged first, then transporting the + bignum causes the layout to see a FP, as would copying an instance whose + layout that is. This is a nearly impossible scenario to create organically + in Lisp, because mostly nothing ever looks again at that exact (EQ) bignum + except for a few things that would cause it to be pinned anyway, + such as it being kept in a local variable during structure manipulation. + See 'interleaved-raw.impure.lisp' for a way to trigger this */ + if (forwarding_pointer_p((lispobj*)bignum)) { + lispobj *forwarded = forwarding_pointer_value((lispobj*)bignum); +#if 0 + fprintf(stderr, "GC bignum_logbitp(): fwd from %p to %p\n", + (void*)bignum, (void*)forwarded); +#endif + bignum = (struct bignum*)native_pointer((lispobj)forwarded); + } + + int len = HeaderValue(bignum->header); + int word_index = index / N_WORD_BITS; + int bit_index = index % N_WORD_BITS; + if (word_index >= len) { + // just return 0 since the marking logic does not allow negative bignums + return 0; + } else { + return (bignum->digits[word_index] >> bit_index) & 1; + } +} + +// Helper function for stepping through the tagged slots of an instance in +// scav_instance and verify_space (which, as it happens, is not useful). +void +instance_scan_interleaved(void (*proc)(), + lispobj *instance_ptr, + sword_t n_words, + lispobj *layout_obj) +{ + struct layout *layout = (struct layout*)layout_obj; + lispobj untagged_metadata = layout->untagged_bitmap; + sword_t index; + + /* This code would be more efficient if the Lisp stored an additional format + of the same metadata - a vector of ranges of slot offsets to scan. + Each pair of vector elements would demarcate the start and end of a range + of offsets to be passed to the proc(). The vector could be either + (unsigned-byte 8) or (unsigned-byte 16) for compactness. + On the other hand, this may not be a bottleneck as-is */ + + ++instance_ptr; // was supplied as the address of the header word + if (untagged_metadata == 0) { + proc(instance_ptr, n_words); + } else if (fixnump(untagged_metadata)) { + unsigned long bitmap = fixnum_value(untagged_metadata); + for (index = 0; index < n_words ; index++, bitmap >>= 1) + if (!(bitmap & 1)) + proc(instance_ptr + index, 1); + } else { /* huge bitmap */ + struct bignum * bitmap; + bitmap = (struct bignum*)native_pointer(untagged_metadata); + for (index = 0; index < n_words ; index++) + if (!positive_bignum_logbitp(index, bitmap)) + proc(instance_ptr + index, 1); + } +} +#endif + static sword_t scav_instance(lispobj *where, lispobj object) { - lispobj nuntagged; sword_t ntotal = HeaderValue(object); lispobj layout = ((struct instance *)where)->slots[0]; if (!layout) return 1; - if (forwarding_pointer_p(native_pointer(layout))) - layout = (lispobj) forwarding_pointer_value(native_pointer(layout)); + layout = (lispobj)native_pointer(layout); + if (forwarding_pointer_p((lispobj*)layout)) + layout = (lispobj)native_pointer((lispobj)forwarding_pointer_value((lispobj*)layout)); - nuntagged = ((struct layout *)native_pointer(layout))->n_untagged_slots; +#ifdef LISP_FEATURE_INTERLEAVED_RAW_SLOTS + instance_scan_interleaved(scavenge, where, ntotal, (lispobj*)layout); +#else + lispobj nuntagged = ((struct layout*)layout)->n_untagged_slots; scavenge(where + 1, ntotal - fixnum_value(nuntagged)); +#endif return ntotal + 1; } diff --git a/src/runtime/gc-internal.h b/src/runtime/gc-internal.h index cf74d9c47..4a873ef3a 100644 --- a/src/runtime/gc-internal.h +++ b/src/runtime/gc-internal.h @@ -177,4 +177,12 @@ extern void scrub_thread_control_stack(struct thread *); # define SIMPLE_ARRAY_WORD_WIDETAG SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG #endif +#ifdef LISP_FEATURE_INTERLEAVED_RAW_SLOTS +extern void +instance_scan_interleaved(void (*proc)(), + lispobj *instance_ptr, + sword_t n_words, + lispobj *layout_obj); +#endif + #endif /* _GC_INTERNAL_H_ */ diff --git a/src/runtime/gencgc.c b/src/runtime/gencgc.c index 347efb437..2658e7406 100644 --- a/src/runtime/gencgc.c +++ b/src/runtime/gencgc.c @@ -3174,17 +3174,23 @@ verify_space(lispobj *start, size_t words) case INSTANCE_HEADER_WIDETAG: { - lispobj nuntagged; sword_t ntotal = HeaderValue(thing); lispobj layout = ((struct instance *)start)->slots[0]; if (!layout) { count = 1; break; } +#ifdef LISP_FEATURE_INTERLEAVED_RAW_SLOTS + instance_scan_interleaved(verify_space, + start, ntotal, + native_pointer(layout)); +#else + lispobj nuntagged; nuntagged = ((struct layout *) native_pointer(layout))->n_untagged_slots; verify_space(start + 1, ntotal - fixnum_value(nuntagged)); +#endif count = ntotal + 1; break; } diff --git a/tests/defstruct.impure.lisp b/tests/defstruct.impure.lisp index b34d80ba6..cbf0bf362 100644 --- a/tests/defstruct.impure.lisp +++ b/tests/defstruct.impure.lisp @@ -473,6 +473,47 @@ (with-test (:name (:defstruct-raw-slot-gc :full)) (check-manyraws *manyraw*)) +(macrolet ((def-it () + `(defstruct (huge-manyraw (:include manyraw)) + ,@(loop for n from 1 to 130 + for s = (write-to-string n) + when (zerop (random 10)) + collect `(,(sb-int:symbolicate "WORD-SLOT-" s) + ,n :type sb-ext:word) + collect `(,(sb-int:symbolicate "SLOT-" s) ,s)) + (df 8.207880688335944d-304 :type double-float) + (aaa 'aaa) + (sf 1.5679403e-38 :type single-float) + (cdf #c(9d0 -2d10) :type (complex double-float)) + (bbb 'bbb) + (csf #c(2f1 2f0) :type (complex single-float)) + (ccc 'ccc) + (w1 #xffee :type sb-ext:word) + (w2 #xeeee :type sb-ext:word)))) + (def-it)) + +(defun check-huge-manyraw (s) + (assert (and (eql (huge-manyraw-df s) 8.207880688335944d-304) + (eql (huge-manyraw-aaa s) 'aaa) + (eql (huge-manyraw-sf s) 1.5679403e-38) + (eql (huge-manyraw-cdf s) #c(9d0 -2d10)) + (eql (huge-manyraw-bbb s) 'bbb) + (eql (huge-manyraw-csf s) #c(2f1 2f0)) + (eql (huge-manyraw-ccc s) 'ccc) + (eql (huge-manyraw-w1 s) #xffee) + (eql (huge-manyraw-w2 s) #xeeee))) + (dolist (slot (sb-kernel:dd-slots + (sb-kernel:layout-info (sb-kernel:layout-of s)))) + (let ((name (string (sb-kernel:dsd-name slot)))) + (cond ((eql (mismatch name "SLOT-") 5) + (let ((n (parse-integer name :start 5))) + (assert (string= (funcall (sb-kernel:dsd-accessor-name slot) s) + (write-to-string n))))) + ((eql (mismatch name "WORD-SLOT-") 10) + (let ((n (parse-integer name :start 10))) + (assert (= (funcall (sb-kernel:dsd-accessor-name slot) s) + n)))))))) + ;;; fasl dumper and loader also have special handling of raw slots, so ;;; dump all of them into a fasl (defmethod make-load-form ((self manyraw) &optional env) @@ -481,7 +522,9 @@ (with-open-file (s "tmp-defstruct.manyraw.lisp" :direction :output :if-exists :supersede) - (write-string "(defun dumped-manyraws () '#.*manyraw*)" s)) + (write-string "(defun dumped-manyraws () '#.*manyraw*)" s) + (terpri s) + (write-string "(defun dumped-huge-manyraw () '#.(make-huge-manyraw))" s)) (compile-file "tmp-defstruct.manyraw.lisp") (delete-file "tmp-defstruct.manyraw.lisp") @@ -492,7 +535,9 @@ ;;; re-read the dumped structures and check them (load "tmp-defstruct.manyraw.fasl") (with-test (:name (:defstruct-raw-slot load)) - (check-manyraws (dumped-manyraws))) + (check-manyraws (dumped-manyraws)) + (check-huge-manyraw (make-huge-manyraw)) + (assert (equalp (make-huge-manyraw) (dumped-huge-manyraw)))) ;;;; miscellaneous old bugs diff --git a/tests/raw-slots-interleaved.impure.lisp b/tests/raw-slots-interleaved.impure.lisp new file mode 100644 index 000000000..507b4de98 --- /dev/null +++ b/tests/raw-slots-interleaved.impure.lisp @@ -0,0 +1,137 @@ +;;;; gc tests + +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. +;;;; +;;;; While most of SBCL is derived from the CMU CL system, the test +;;;; files (like this one) were written from scratch after the fork +;;;; from CMU CL. +;;; +;;;; This software is in the public domain and is provided with +;;;; absoluely no warranty. See the COPYING and CREDITS files for +;;;; more information. + +(in-package :cl-user) + +#-interleaved-raw-slots (invoke-restart 'run-tests::skip-file) + +;;; More tests of raw slots can be found in 'defstruct.impure.lisp' +;;; Since those are all passing, it's fair to say that interleaving works. +;;; But we want also to test what happens in a very specific case that +;;; is difficult to provoke, when a structure contains enough slots that +;;; its raw bitmap is a bignum and the bignum is moved during GC. + +(macrolet ((defbiggy () + `(defstruct biggy + ,@(loop for i from 1 to 62 + collect `(,(sb-int:symbolicate "SLOT" (write-to-string i)) + 0 :type ,(if (> i 60) 'sb-ext:word t)))))) + (defbiggy)) + +(assert (typep (sb-kernel:layout-raw-slot-metadata + (sb-kernel::find-layout 'biggy)) 'bignum)) + +(defvar *x* nil) +(defvar *y* nil) + +;; This test offers "anecdotal evidence" that it works to have +;; a bignum for raw slot metadata, *and* that the bignum could be +;; transported by GC, leaving a forwarding pointer, +;; before transporting an instance of an object whose layout +;; sees the bignum. + +;; Without extra augmentation of the GC code [such as printf("got here!")] +;; there is no visible means of determining that this works, +;; aside from GC not crashing. +;; Additionally, the test does not work - which is to say, the GC behavior +;; is different and the desired effect can't be observed - when placed in +;; a WITH-TEST or any other toplevel "noise"; but even without that, +;; the test is brittle. +;; With some extra annotation (printf of otherwise), the line +;; of code in positive_bignum_logbitp() is seen to be reached 63 times +;; in each test run, corresponding to the 63 slots (counting the layout) +;; in each structure instance, times two structure instances. + +;; Run it twice to make sure things really worked. + +(let ((*y* (make-biggy)) + (*x* (sb-kernel:layout-raw-slot-metadata + (sb-kernel::find-layout 'biggy)))) + (sb-ext:gc :gen 1)) +(princ 'did-pass-1) (terpri) +(force-output) + +(let ((*y* (make-biggy)) + (*x* (sb-kernel:layout-raw-slot-metadata + (sb-kernel::find-layout 'biggy)))) + (sb-ext:gc :gen 1)) +(princ 'did-pass-2) (terpri) +(force-output) + +;; Test the C bignum bit extractor. +;; Surprisingly, there was a bug in it, unrelated to forwarding +;; pointers that remained dormant until the randomized +;; HUGE-MANYRAW test in 'defstruct.impure.lisp' found it. +(defun c-bignum-logbitp (index bignum) + (assert (typep bignum 'bignum)) + (sb-sys:with-pinned-objects (bignum) + (alien-funcall (extern-alien "positive_bignum_logbitp" + (function long int long)) + index + (- (sb-kernel:get-lisp-obj-address bignum) + sb-vm:other-pointer-lowtag)))) + +(with-test (:name :c-bignum-logbitp) + ;; walking 1 bit + (dotimes (i 256) + (let ((num (ash 1 i))) + (when (typep num 'bignum) + (dotimes (j 257) + (assert (= (c-bignum-logbitp j num) + (if (logbitp j num) 1 0))))))) + ;; random bits + (let ((max (ash 1 768))) + (dotimes (i 100) + (let ((num (random max))) + (when (typep num 'bignum) + (dotimes (j (* (sb-bignum:%bignum-length num) + sb-vm:n-word-bits)) + (assert (= (c-bignum-logbitp j num) + (if (logbitp j num) 1 0))))))))) + +;; for testing the comparator +(defstruct foo1 + (df 1d0 :type double-float) ; index 1 + (a 'aaay) ; index 2 + (sf 1f0 :type single-float) ; index 3 + (cdf #c(1d0 1d0) :type (complex double-float)) ; indices 4 and 5 + (b 'bee) ; index 6 + (csf #c(2f0 2f0) :type (complex single-float)) ; index 7 + (w 0 :type sb-ext:word) ; index 8 + (c 'cee)) ; index 9 + +(defvar *afoo* (make-foo1)) +(with-test (:name :tagged-slot-iterator-macro) + (setf (sb-kernel:%instance-ref *afoo* 10) 'magic) + (let (l) + (sb-kernel:do-instance-tagged-slot (i *afoo*) + (push `(,i ,(sb-kernel:%instance-ref *afoo* i)) l)) + (assert (oddp (sb-kernel:%instance-length *afoo*))) + (assert (= (sb-kernel:layout-length (sb-kernel:layout-of *afoo*)) + (1- (sb-kernel:%instance-length *afoo*)))) + (assert (equalp (nreverse l) + `((0 ,(sb-kernel:find-layout 'foo1)) + (2 aaay) + (6 bee) + (9 cee) + ;; slots 1 through 10 exist, to keep total + ;; object length EVEN. + (10 magic)))))) + +(defvar *anotherfoo* (make-foo1)) + +(with-test (:name :structure-obj-equalp-raw-slots) + ;; these structures are EQUALP even though one of them + ;; has a word of junk in its padding slot, as could happen + ;; if the structure was stack-allocated (I think) + (assert (equalp *anotherfoo* *afoo*))) -- 2.11.4.GIT