master: Assign layout-ids just-in-time as originally intended
snuglas via Sbcl-commits <[email protected]>
| Newsgroups | gmane.lisp.steel-bank.cvs |
|---|---|
| Message-ID | <[email protected]> |
The branch "master" has been updated in SBCL:
via 8a26a86d766e650eb5058b5f0724447ee063aaea (commit)
from 06151ad1c15b0097deaa12176e999f278f6747ab (commit)
- Log -----------------------------------------------------------------
commit 8a26a86d766e650eb5058b5f0724447ee063aaea
Author: Douglas Katzman <[email protected]>
Date: Mon Aug 17 19:15:29 2026 -0400
Assign layout-ids just-in-time as originally intended
This wasn't working right, and the assertion in LAYOUT-ID about assigning
only structures an ID was written incorrectly.
* Layout IDs are assigned only when applying a :layout-id fixup or when storing
into a descendant type's ID array, whichever occurs first.
* IDs of non-structure instances like STREAM that have nonzero IDs are
stored at the correct place for their depthoid, and not always at index 0
so that LAYOUT-ID doesn't have to test +structure-layout-flag+.
* LAYOUT-ID returns NIL instead of 0 if no ID is assigned.
machine-dependent files will never see the 0.
* The remark that IDs could do type-based dispatch is no longer hypothetical
---
src/code/class.lisp | 2 +-
src/code/cross-type.lisp | 2 ++
src/code/target-defstruct.lisp | 50 ++++++++++++++++-----------------
src/cold/exports.lisp | 2 +-
src/compiler/arm/system.lisp | 2 +-
src/compiler/arm64/type-vops.lisp | 4 +--
src/compiler/generic/core.lisp | 2 +-
src/compiler/generic/genesis.lisp | 15 ++++++----
src/compiler/generic/layout-ids.lisp | 2 +-
src/compiler/generic/utils.lisp | 10 +++++++
src/compiler/loongarch64/system.lisp | 10 +++----
src/compiler/ppc/system.lisp | 9 ++----
src/compiler/ppc64/system.lisp | 9 ++----
src/compiler/riscv/system.lisp | 10 +++----
src/compiler/sparc/system.lisp | 10 +++----
src/compiler/x86-64/type-vops.lisp | 20 ++-----------
src/compiler/x86/system.lisp | 5 +---
tests/layouts.pure.lisp | 54 ++++++++++++++----------------------
18 files changed, 100 insertions(+), 118 deletions(-)
diff --git a/src/code/class.lisp b/src/code/class.lisp
index e2b57c602..dbb113762 100644
--- a/src/code/class.lisp
+++ b/src/code/class.lisp
@@ -140,7 +140,7 @@
(print-unreadable-object (layout stream :type t :identity t)
(format stream
"~@[(ID=~d) ~]for ~S~@[, INVALID=~S~]"
- (layout-id layout #-sb-xc-host nil)
+ (layout-id layout)
(layout-proper-name layout)
(layout-invalid layout))))
diff --git a/src/code/cross-type.lisp b/src/code/cross-type.lisp
index e24b55af6..6502e644f 100644
--- a/src/code/cross-type.lisp
+++ b/src/code/cross-type.lisp
@@ -382,3 +382,5 @@
(defun sb-bignum:%bignum-length (x)
(values (ceiling (1+ (integer-length x)) sb-vm:n-word-bits)))
+
+(defun ensure-layout-id (layout) (declare (ignore layout)) (error "Should not get here"))
diff --git a/src/code/target-defstruct.lisp b/src/code/target-defstruct.lisp
index 93540faf3..bdf2cf710 100644
--- a/src/code/target-defstruct.lisp
+++ b/src/code/target-defstruct.lisp
@@ -100,7 +100,7 @@
;; - only subtypes of STRUCTURE-OBJECT need an ID for TYPEP, and structures
;; are not redefinable, so you'd have to define 2^32 different structure
;; types to exhaust the space of IDS.
- (set-layout-inherits layout inherits (logtest flags +structure-layout-flag+) 0)
+ (set-layout-inherits layout inherits (logtest flags +structure-layout-flag+) nil)
(let ((bitmap-base (+ fixed-words extra-id-words)))
(dotimes (i bitmap-words)
(%raw-instance-set/word layout (+ bitmap-base i)
@@ -197,32 +197,30 @@
layout (+ (get-dsd-index layout id-word0) index))
;; use SAP-ref, for lack of half-sized slots
#+64-bit `(signed-sap-ref-32 (id-bits-sap) (ash index 2))))
-(defun layout-id (layout &optional (assign t))
+(defun layout-id (layout)
;; If a structure type at depthoid >= 2, then fetch the INDEXth id
;; where INDEX is depthoid - 2. Otherwise fetch the 0th id.
;; There are a few non-structure types at positive depthoid; those do not store
;; their ancestors in the vector; they only store self-id at index 0.
;; This isn't performance-critical. If it were, then we should store self-ID
- ;; at a fixed index. Using it for type-based dispatch remains a possibility.
- (let* ((depth (- (sb-vm::layout-depthoid layout) 2))
- (index (if (or (< depth 0) (not (logtest (layout-flags layout)
- +structure-layout-flag+)))
- 0 depth))
- (id (with-pinned-objects (layout)
- (access-it))))
- (truly-the
- (or null layout-id)
- (cond ((not (zerop id)) id)
- (assign
- (aver (logior +structure-layout-flag+ (layout-flags layout)))
- (with-system-mutex (*layout-id-mutex*)
- (let ((id (truly-the layout-id (access-it)))) ; double-check
- (if (zerop id)
- (with-pinned-objects (layout)
- (setf (access-it)
- ;; doesn't really need ATOMIC- any moren
- (atomic-incf (car *layout-id-generator*))))
- id))))))))
+ ;; at a fixed index.
+ (let* ((index (max 0 (- (sb-vm::layout-depthoid layout) 2)))
+ (id (with-pinned-objects (layout) (access-it))))
+ (unless (zerop id) id)))
+
+(defun ensure-layout-id (layout)
+ (or (layout-id layout)
+ (progn
+ (aver (logtest (layout-flags layout) +structure-layout-flag+))
+ (with-system-mutex (*layout-id-mutex*)
+ (let* ((index (max 0 (- (sb-vm::layout-depthoid layout) 2)))
+ (id (access-it))) ; double-check
+ (if (zerop id)
+ (with-pinned-objects (layout)
+ (setf (access-it)
+ ;; doesn't really need ATOMIC- any more
+ (atomic-incf (car *layout-id-generator*))))
+ id))))))
(defun set-layout-inherits (layout inherits structurep this-id)
(setf (layout-inherits layout) inherits)
@@ -243,9 +241,11 @@
(cond (structurep
(loop for i from 0 by 4
for j from 2 below (length inherits) ; skip T and STRUCTURE-OBJECT
- do (setf (signed-sap-ref-32 sap i) (layout-id (svref inherits j)))
- finally (setf (signed-sap-ref-32 sap i) this-id)))
- ((not (eql this-id 0))
+ do (setf (signed-sap-ref-32 sap i) (ensure-layout-id (svref inherits j)))
+ finally (setf (signed-sap-ref-32 sap i) (or this-id 0))))
+ (this-id ; it shold only be nonzero for a very restricted number
+ ;; of non-structures. Maybe should assert that we're not assigning
+ ;; numbers to every standard-object.
(setf (signed-sap-ref-32 sap 0) this-id))))))
) ; end MACROLET
diff --git a/src/cold/exports.lisp b/src/cold/exports.lisp
index 7230aef2f..f499c1ced 100644
--- a/src/cold/exports.lisp
+++ b/src/cold/exports.lisp
@@ -1842,7 +1842,7 @@ is a good idea, but see SB-SYS re. blurring of boundaries.")
"LAYOUT-EQUALP-IMPL"
"BITMAP-NWORDS"
"LAYOUT-DEPTHOID"
- "LAYOUT-ID"
+ "LAYOUT-ID" "ENSURE-LAYOUT-ID"
"LAYOUT-FOR-PCL-OBJ-P"
#+(or x86-64 x86) "%LEA"
"LEXENV" "LEXENV-DESIGNATOR" "LINE-LENGTH"
diff --git a/src/compiler/arm/system.lisp b/src/compiler/arm/system.lisp
index 3047f4518..1a09fa728 100644
--- a/src/compiler/arm/system.lisp
+++ b/src/compiler/arm/system.lisp
@@ -81,7 +81,7 @@
(inst ldr this-id (@ x (layout-id-offset test-layout)))
(let ((test-id (layout-id test-layout)))
;; 8-bit IDs are permanently assigned, so no fixup ever needed for those.
- (cond ((typep test-id '(and (unsigned-byte 8) (not (eql 0))))
+ (cond ((typep test-id '(unsigned-byte 8))
(inst cmp this-id test-id))
(t
(inst .layout-id test-layout)
diff --git a/src/compiler/arm64/type-vops.lisp b/src/compiler/arm64/type-vops.lisp
index d17d67c7b..ba725fda3 100644
--- a/src/compiler/arm64/type-vops.lisp
+++ b/src/compiler/arm64/type-vops.lisp
@@ -842,7 +842,7 @@
(inst b :lt (if not-p target done)))
(inst ldr (32-bit-reg this-id) (@ layout (layout-id-offset test-layout)))
;; 8-bit IDs are permanently assigned, so no fixup ever needed for those.
- (cond ((typep test-id '(and (signed-byte 8) (not (eql 0))))
+ (cond ((typep test-id '(signed-byte 8))
(if (minusp test-id)
(inst cmn (32-bit-reg this-id) (- test-id))
(inst cmp (32-bit-reg this-id) test-id)))
@@ -948,7 +948,7 @@
(:temporary (:sc non-descriptor-reg) temp)
(:generator 1
(let ((test-id (layout-id test-layout)))
- (cond ((typep test-id '(and (signed-byte 8) (not (eql 0))))
+ (cond ((typep test-id '(signed-byte 8))
(if (minusp test-id)
(inst cmn (32-bit-reg id) (- test-id))
(inst cmp (32-bit-reg id) test-id)))
diff --git a/src/compiler/generic/core.lisp b/src/compiler/generic/core.lisp
index bc21444c5..a01497da8 100644
--- a/src/compiler/generic/core.lisp
+++ b/src/compiler/generic/core.lisp
@@ -95,7 +95,7 @@
#+sb-thread (:symbol-tls-index (ensure-symbol-tls-index name))
(:layout (get-lisp-obj-address
(if (symbolp name) (find-layout name) name)))
- (:layout-id (layout-id name))
+ (:layout-id (ensure-layout-id name))
(:card-table-index-mask (extern-alien "gc_card_table_nbits" int))
(:immobile-symbol (get-lisp-obj-address name))
(t (bug "bad fixup flavor ~s" flavor)))
diff --git a/src/compiler/generic/genesis.lisp b/src/compiler/generic/genesis.lisp
index 2fe7a0fe1..141609714 100644
--- a/src/compiler/generic/genesis.lisp
+++ b/src/compiler/generic/genesis.lisp
@@ -850,7 +850,10 @@
;;; in the core for a cold layout, so that we don't have to extract
;;; them out of the core to compare cold layouts for validity.
(defstruct (cold-layout (:constructor %make-cold-layout))
- id name depthoid length bitmap flags inherits descriptor)
+ ;; ID is NIL for non-structures, and NIL is stored as 0. We want to enforce
+ ;; the constraint that that no layout has an actual ID is 0.
+ (id nil :type (or (and fixnum (not (eql 0))) null))
+ name depthoid length bitmap flags inherits descriptor)
;;; a map from name as a host symbol to the descriptor of its target layout
(defvar *cold-layouts*)
@@ -1451,13 +1454,15 @@ core and return a descriptor to it."
(host-constant-to-core '#(1 nil))))))
(let ((byte-offset (+ (descriptor-byte-offset result) (sb-vm::id-bits-offset))))
+ (when this-id
+ (let ((disp (+ byte-offset (ash (max 0 (- depthoid 2)) 2))))
+ (setf (bvref-s32 (descriptor-mem result) disp) this-id)))
(when (logtest flags +structure-layout-flag+)
(loop for i from 2 below (cold-vector-len inherits)
do (setf (bvref-s32 (descriptor-mem result) byte-offset)
(cold-layout-id (gethash (descriptor-bits (cold-svref inherits i))
*cold-layout-by-addr*)))
- (incf byte-offset 4)))
- (setf (bvref-s32 (descriptor-mem result) byte-offset) this-id)))
+ (incf byte-offset 4)))))
(integer-bits-to-core bitmap result (1+ fixed-words) bitmap-words)
@@ -3046,8 +3051,8 @@ Legal values for OFFSET are -4, -8, -12, ..."
(:symbol-tls-index (ensure-symbol-tls-index name))
(:layout (cold-layout-descriptor-bits name))
(:layout-id ; SYM is a #<LAYOUT>
- (cold-layout-id (gethash (descriptor-bits name)
- *cold-layout-by-addr*)))
+ (the (and fixnum (not (eql 0)))
+ (cold-layout-id (gethash (descriptor-bits name) *cold-layout-by-addr*))))
;; The machine-dependent code decides how to patch in 'nbits'
(:card-table-index-mask sb-vm::gencgc-card-table-index-nbits)
(:immobile-symbol
diff --git a/src/compiler/generic/layout-ids.lisp b/src/compiler/generic/layout-ids.lisp
index 08097eacb..3b6141c07 100644
--- a/src/compiler/generic/layout-ids.lisp
+++ b/src/compiler/generic/layout-ids.lisp
@@ -271,7 +271,7 @@ SB-C::DXABLE-ARGS
#-sb-xc
(defun choose-layout-id (name conditionp)
(case name
- ((t) 0)
+ ((t) nil)
(structure-object 1)
(sb-impl::buffer 2)
(layout 3)
diff --git a/src/compiler/generic/utils.lisp b/src/compiler/generic/utils.lisp
index 3e4acfb3a..762396717 100644
--- a/src/compiler/generic/utils.lisp
+++ b/src/compiler/generic/utils.lisp
@@ -544,6 +544,16 @@
(defmacro id-bits-offset () ; FIXME: could this be a constant ?
(let ((slot (get-dsd-index layout sb-kernel::id-word0)))
(ash (+ sb-vm:instance-slots-offset slot) sb-vm:word-shift)))
+
+(defmacro ensure-layout-id-fixup-or-imm (l)
+ ;; If not compiling to a file, then ensure we have an ID, and use it as an immediate
+ ;; operand. (If the backend can't do that due to encoding limitations, it can choose to
+ ;; use a fixup). Otherwise, if the ID is a small integer for a builtin layout - so it won't
+ ;; change - then wire it in even if compiling to a file. Otherwise, returnd a fixup.
+ `(cond ((not (sb-c::producing-fasl-file)) (ensure-layout-id ,l)) ; assign it now
+ ((typep (layout-id ,l) '(signed-byte 8)) (layout-id ,l)) ; a known small id
+ (t (make-fixup ,l :layout-id))))
+
(defmacro layout-id-offset (layout)
;; Compute offset at which you can read a layout-id from an unknown layout to see
;; if it matches the ID at the depthoid of LAYOUT.
diff --git a/src/compiler/loongarch64/system.lisp b/src/compiler/loongarch64/system.lisp
index 55ad453c3..d2a1e5a6b 100644
--- a/src/compiler/loongarch64/system.lisp
+++ b/src/compiler/loongarch64/system.lisp
@@ -78,12 +78,12 @@
(:info target not-p test-layout)
(:temporary (:sc unsigned-reg) this-id temp)
(:generator 4
- (inst ld.w this-id x (layout-id-offset test-layout))
- (if (or (typep (layout-id test-layout) '(and (signed-byte 8) (not (eql 0))))
- (not (sb-c::producing-fasl-file)))
- (inst li temp (layout-id test-layout))
+ (inst ld.w this-id x (layout-id-offset test-layout))
+ (let ((operand (ensure-layout-id-fixup-or-imm test-layout)))
+ (if (fixnump operand)
+ (inst li temp operand)
(inst load-layout-id temp test-layout))
- (inst* (if not-p 'bne 'beq) this-id temp target)))
+ (inst* (if not-p 'bne 'beq) this-id temp target))))
(define-vop (layout-depthoid)
(:translate layout-depthoid)
diff --git a/src/compiler/ppc/system.lisp b/src/compiler/ppc/system.lisp
index 173321001..0f65fcab2 100644
--- a/src/compiler/ppc/system.lisp
+++ b/src/compiler/ppc/system.lisp
@@ -68,12 +68,9 @@
(:temporary (:scs (non-descriptor-reg)) this-id that-id)
(:generator 4
(inst lwz this-id x (layout-id-offset test-layout))
- (let ((test-id (layout-id test-layout)))
- ;; Always prefer 'cmpwi' if compiling to memory.
- ;; 8-bit IDs are permanently assigned, so no fixup ever needed for those.
- (cond ((or (typep test-id '(and (signed-byte 8) (not (eql 0))))
- (and (not (sb-c::producing-fasl-file))
- (typep test-id '(signed-byte 16))))
+ (let ((test-id (ensure-layout-id-fixup-or-imm test-layout)))
+ ;; When compiling to memory prefer to use the 'cmpwi' instruction if TEST-ID is encodable
+ (cond ((typep test-id '(signed-byte 16))
(inst cmpwi this-id test-id))
(t
(inst lwz that-id code-tn
diff --git a/src/compiler/ppc64/system.lisp b/src/compiler/ppc64/system.lisp
index d8d591168..b0cc52a94 100644
--- a/src/compiler/ppc64/system.lisp
+++ b/src/compiler/ppc64/system.lisp
@@ -84,12 +84,9 @@
(:temporary (:scs (non-descriptor-reg)) this-id)
(:generator 4
(inst lwa this-id x (layout-id-offset test-layout))
- (let ((test-id (layout-id test-layout)))
- ;; Always prefer 'cmpwi' if compiling to memory.
- ;; 8-bit IDs are permanently assigned, so no fixup ever needed for those.
- (cond ((or (typep test-id '(and (signed-byte 8) (not (eql 0))))
- (and (not (sb-c::producing-fasl-file))
- (typep test-id '(signed-byte 16))))
+ (let ((test-id (ensure-layout-id-fixup-or-imm test-layout)))
+ ;; When compiling to memory prefer to use the 'cmpwi' instruction if TEST-ID is encodable
+ (cond ((typep test-id '(signed-byte 16))
(inst cmpwi this-id test-id))
(t
(inst lwa temp-reg-tn code-tn
diff --git a/src/compiler/riscv/system.lisp b/src/compiler/riscv/system.lisp
index e48153702..64dceab6c 100644
--- a/src/compiler/riscv/system.lisp
+++ b/src/compiler/riscv/system.lisp
@@ -78,12 +78,12 @@
(:info target not-p test-layout)
(:temporary (:sc unsigned-reg) this-id temp)
(:generator 4
- (inst lw this-id x (layout-id-offset test-layout))
- (if (or (typep (layout-id test-layout) '(and (signed-byte 8) (not (eql 0))))
- (not (sb-c::producing-fasl-file)))
- (inst li temp (layout-id test-layout))
+ (inst lw this-id x (layout-id-offset test-layout))
+ (let ((operand (ensure-layout-id-fixup-or-imm test-layout)))
+ (if (fixnump operand)
+ (inst li temp operand)
(inst load-layout-id temp test-layout))
- (inst* (if not-p 'bne 'beq) this-id temp target)))
+ (inst* (if not-p 'bne 'beq) this-id temp target))))
#+64-bit
(define-vop (layout-depthoid)
diff --git a/src/compiler/sparc/system.lisp b/src/compiler/sparc/system.lisp
index 68c137e81..069d68d56 100644
--- a/src/compiler/sparc/system.lisp
+++ b/src/compiler/sparc/system.lisp
@@ -70,14 +70,14 @@
(:info target not-p test-layout)
(:temporary (:sc unsigned-reg) this-id temp)
(:generator 4
- (inst ld this-id x (layout-id-offset test-layout))
- (if (or (typep (layout-id test-layout) '(and (signed-byte 8) (not (eql 0))))
- (not (sb-c::producing-fasl-file)))
- (inst li temp (layout-id test-layout))
+ (inst ld this-id x (layout-id-offset test-layout))
+ (let ((operand (ensure-layout-id-fixup-or-imm test-layout)))
+ (if (fixnump operand)
+ (inst li temp operand)
(inst load-layout-id temp test-layout))
(inst cmp this-id temp)
(inst b (if not-p :ne :eq) target)
- (inst nop)))
+ (inst nop))))
(define-vop (%other-pointer-widetag)
(:translate %other-pointer-widetag)
diff --git a/src/compiler/x86-64/type-vops.lisp b/src/compiler/x86-64/type-vops.lisp
index c01b08a56..0005e9528 100644
--- a/src/compiler/x86-64/type-vops.lisp
+++ b/src/compiler/x86-64/type-vops.lisp
@@ -1267,17 +1267,8 @@
(inst jmp :l (if not-p target done)))
(inst cmp :dword
(ea (layout-id-offset test-layout) layout)
- ;; Small layout-ids can only occur for layouts made in genesis.
- ;; Therefore if the compile-time value of the ID is small,
- ;; it is permanently assigned to that type.
- ;; Otherwise, we allow for the possibility that the compile-time ID
- ;; is not the same as the load-time ID.
- ;; I don't think layout-id 0 can get here, but be sure to exclude it.
- (cond ((or (typep (layout-id test-layout) '(and (signed-byte 8) (not (eql 0))))
- (not (sb-c::producing-fasl-file)))
- (layout-id test-layout))
- (t
- (make-fixup test-layout :layout-id))))))))))
+ (ensure-layout-id-fixup-or-imm test-layout)))))))
+) ; end MACROLET
(define-vop ()
(:translate sb-c::%structure-is-a)
@@ -1368,10 +1359,5 @@
(:policy :fast-safe)
(:info target not-p test-layout)
(:generator 1
- (inst cmp :dword id
- (cond ((or (typep (layout-id test-layout) '(and (signed-byte 8) (not (eql 0))))
- (not (sb-c::producing-fasl-file)))
- (layout-id test-layout))
- (t
- (make-fixup test-layout :layout-id))))
+ (inst cmp :dword id (ensure-layout-id-fixup-or-imm test-layout))
(inst jmp (if not-p :ne :e) target)))
diff --git a/src/compiler/x86/system.lisp b/src/compiler/x86/system.lisp
index 724670047..68699d8b2 100644
--- a/src/compiler/x86/system.lisp
+++ b/src/compiler/x86/system.lisp
@@ -77,10 +77,7 @@
(:generator 1
(inst cmp
(make-ea :dword :disp (layout-id-offset test) :base x)
- (if (or (typep (layout-id test) '(and (signed-byte 8) (not (eql 0))))
- (not (sb-c::producing-fasl-file)))
- (layout-id test)
- (make-fixup test :layout-id)))))
+ (ensure-layout-id-fixup-or-imm test))))
(define-vop (%other-pointer-widetag)
(:translate %other-pointer-widetag)
diff --git a/tests/layouts.pure.lisp b/tests/layouts.pure.lisp
index d74d1f79c..7f40738b5 100644
--- a/tests/layouts.pure.lisp
+++ b/tests/layouts.pure.lisp
@@ -116,50 +116,38 @@
sb-vm:word-shift)
sb-vm:instance-pointer-lowtag)))
-;;;; Ensure ID uniqueness and that layout ID words match the ID's in the INHERITS vector.
-(defparameter *all-wrappers*
- (delete-if
- ;; temporary layouts (created for parsing DEFSTRUCT)
- ;; must be be culled out.
- (lambda (x)
- (and (typep (sb-kernel:layout-classoid x)
- 'sb-kernel:structure-classoid)
- (eq (sb-kernel:layout-equalp-impl x)
- #'sb-kernel::equalp-err)))
- (sb-vm::list-allocated-objects :all
- :type sb-vm:instance-widetag
- :test #'sb-kernel::layout-p)))
-
;;; Assert no overlaps on ID
(with-test (:name :id-uniqueness)
- (let ((hash (make-hash-table)))
- (dolist (wrapper *all-wrappers*)
+ (let ((hash (make-hash-table))
+ (all-layouts
+ (sb-vm::list-allocated-objects :all
+ :type sb-vm:instance-widetag
+ :test #'sb-kernel::layout-p)))
+ (dolist (wrapper all-layouts)
(let ((id (sb-kernel:layout-id wrapper)))
- (sb-int:awhen (gethash id hash)
- (error "ID ~D is ~A and ~A" id sb-int:it wrapper))
- (setf (gethash id hash) wrapper)))))
+ (when id ; not all layouts have IDs
+ (sb-int:awhen (gethash id hash)
+ (error "ID ~D is ~A and ~A" id sb-int:it wrapper))
+ (setf (gethash id hash) wrapper))))))
;;; Assert that IDs are right
(with-test (:name :id-versus-inherits)
- (let ((structure-object (sb-kernel:find-layout 'structure-object)))
- (dolist (wrapper *all-wrappers*)
- (when (find structure-object (sb-kernel:layout-inherits wrapper))
- (let* ((layout wrapper)
- (ids
+ (let ((structure-layouts
+ (loop for v being each hash-value
+ of (sb-kernel:classoid-subclasses (sb-kernel:find-classoid 'structure-object))
+ collect v)))
+ (dolist (layout structure-layouts)
+ (let* ((ids
(sb-sys:with-pinned-objects (layout)
(let ((sap (layout-id-vector-sap layout)))
- (loop for depthoid from 2 to (sb-kernel:layout-depthoid wrapper)
+ (loop for depthoid from 2 below (sb-kernel:layout-depthoid layout)
collect (sb-sys:signed-sap-ref-32 sap (ash (- depthoid 2) 2))))))
(expected
- (map 'list 'sb-kernel:layout-id (sb-kernel:layout-inherits wrapper))))
- (unless (equal (list* (sb-kernel:layout-id (sb-kernel:find-layout 't))
- (sb-kernel:layout-id (sb-kernel:find-layout 'structure-object))
- ids)
- (append expected (list (sb-kernel:layout-id wrapper))))
+ (map 'list 'sb-kernel:layout-id (subseq (sb-kernel:layout-inherits layout) 2))))
+ (unless (equal ids expected)
+ (setq *print-pretty* nil)
(error "Wrong IDs for ~A: expect ~D actual ~D~%"
- wrapper expected ids)))))))
-
-(makunbound '*all-wrappers*)
+ layout expected ids))))))
(defun random-bitmap (nwords random-state sign-bit)
(let ((integer 0)
-----------------------------------------------------------------------
hooks/post-receive
--
SBCL